Информационный портал для профессионалов в области САПР
Вы не вошли. Пожалуйста, войдите или зарегистрируйтесь.
Форумы CADUser → Программирование → VBA → Помогите с фильтром
Страницы 1
Чтобы отправить ответ, вы должны войти или зарегистрироваться
Как сделать выборку объектов по определенному слою и интересующих типов объектов. В файле десятки тысяч объектов и пробегать их всех для нахождения интересующих не совсем оптимально т.к. выборки необходимо проделать пару десятков раз с различными критериями. Интерезуют такие выборки
найти все AcDb3dPolyline которые находятся на слое Sloy. И найти AcDbPoint и AcDbPolyline на Sloy2.
> SmeL
Я еще меньше тебя наверно знаю, но спробуй:
Option Explicit
'<|>----------<|>-- grabbed from {Smirnoff} --<|>----------<|>'
Public Function Sel3dPolyByLayer(layName As String) As AcadSelectionSet
Dim setCol As AcadSelectionSets
Dim refSet As AcadSelectionSet
Dim filType(0 To 2) As Integer
Dim filData(0 To 2) As Variant
Set setCol = ThisDrawing.SelectionSets
filType(0) = 0
filType(1) = 100
filType(2) = 8
filData(0) = "POLYLINE"
filData(1) = "AcDbPolyline"
filData(2) = layName
For Each refSet In setCol
If refSet.Name = "Ref_Set" Then
refSet.Delete
Exit For
End If
Next refSet
Set refSet = setCol.Add("Ref_Set")
refSet.Select acSelectionSetAll, , , filType, filData
Set Sel3dPolyByLayer = refSet
End Function
Sub Test_3dpoly_Select()
Dim layName As String
Dim SelSet As AcadSelectionSet
On Error GoTo ErrHand
layName = "Sloy"
Set SelSet = Sel3dPolyByLayer(layName)
MsgBox "Found " & CStr(SelSet.Count) & " 3d polylines " & layName
ErrHand:
MsgBox Err.Description
End Sub
Public Function SelPointByLayer(layName As String) As AcadSelectionSet
Dim setCol As AcadSelectionSets
Dim refSet As AcadSelectionSet
Dim filType(0 To 1) As Integer
Dim filData(0 To 1) As Variant
Set setCol = ThisDrawing.SelectionSets
filType(0) = 0
filType(1) = 8
filData(0) = "POINT"
filData(1) = layName
For Each refSet In setCol
If refSet.Name = "Ref_Set_Points" Then
refSet.Delete
Exit For
End If
Next refSet
Set refSet = setCol.Add("Ref_Set_Points")
refSet.Select acSelectionSetAll, , , filType, filData
Set SelPointByLayer = refSet
End Function
Sub Test_PointByLayer_Select()
Dim layName As String
Dim SelSet As AcadSelectionSet
On Error GoTo ErrHand
layName = "Sloy2"
Set SelSet = SelPointByLayer(layName)
MsgBox "Found " & CStr(SelSet.Count) & " points " & layName
ErrHand:
MsgBox Err.Description
End Sub~'J'~
На всякий случай поправлюсь:
А для точек фильтр будет типа:
filType(0) = 0 filType(1) = 8 filData(0) = "POINT" filData(1) = layName
~'J'~
Пока я собирался, люди уже отозвались...
Но все таки, может и этот пример пригодится?
В нем использован код отсюда:
http://www.cad.dp.ua/stats/a_vba/conten … xtOnScreen
Sub SelectionTest_1()
'AcDb3dPolyline on layer Sloy:
Dim objSelSet As AcadSelectionSet
Dim objSelCol As AcadSelectionSets
Dim intDXF(3) As Integer
Dim varVal(3) As Variant
Set objSelCol = ThisDrawing.SelectionSets
For Each objSelSet In objSelCol
If objSelSet.Name = "Test_Sel" Then
objSelSet.Delete
Exit For
End If
Next
Set objSelSet = ThisDrawing.SelectionSets.Add("Test_Sel")
Dim intType(0 To 3) As Integer
Dim varData(0 To 3) As Variant
intType(0) = -4: varData(0) = "<AND"
intType(1) = 0: varData(1) = "POLYLINE"
intType(2) = 8: varData(2) = "Sloy"
intType(3) = -4: varData(3) = "AND>"
objSelSet.Select acSelectionSetAll, Filtertype:=intType, filterdata:=varData
For Each objEnt In objSelSet
objEnt.Highlight True
Next
MsgBox "AcDb3dPolyline on layer Sloy"
For Each objEnt In objSelSet
objEnt.Highlight False
Next
objSelSet.Clear
'AcDbPoint and AcDbPolyline on layer Sloy2:
Dim intType1(0 To 6) As Integer
Dim varData1(0 To 6) As Variant
intType1(0) = -4: varData1(0) = "<AND"
intType1(1) = -4: varData1(1) = "<OR"
intType1(2) = 0: varData1(2) = "LWPOLYLINE"
intType1(3) = 0: varData1(3) = "POINT"
intType1(4) = -4: varData1(4) = "OR>"
intType1(5) = 8: varData1(5) = "Sloy2"
intType1(6) = -4: varData1(6) = "AND>"
objSelSet.Select acSelectionSetAll, Filtertype:=intType1, filterdata:=varData1
For Each objEnt In objSelSet
objEnt.Highlight True
Next
MsgBox "AcDbPoint and AcDbPolyline on layer Sloy2"
End Sub> LeonidSN
Дык и намного красивше, есть чему учиться
Спасибо
~'J'~
listing1
Public Sub trigerSUB(layerName As String, Optional asPoint As Boolean = True)
Dim objSelSet As AcadSelectionSet
Dim objEnt As AcadEntity
Dim intType1(0 To 6) As Integer
Dim varData1(0 To 6) As Variant
If asPoint Then
intType1(0) = -4: varData1(0) = "<AND"
intType1(1) = -4: varData1(1) = "<OR"
intType1(2) = 0: varData1(2) = ""
intType1(3) = 0: varData1(3) = "POINT"
intType1(4) = -4: varData1(4) = "OR>"
intType1(5) = 8: varData1(5) = layerName
intType1(6) = -4: varData1(6) = "AND>"
Else
intType1(0) = -4: varData1(0) = "<AND"
intType1(1) = -4: varData1(1) = "<OR"
intType1(2) = 0: varData1(2) = "LWPOLYLINE"
intType1(3) = 0: varData1(3) = "POLYLINE"
intType1(4) = -4: varData1(4) = "OR>"
intType1(5) = 8: varData1(5) = layerName
intType1(6) = -4: varData1(6) = "AND>"
End If
Set objSelSet = SmatrSel(intType1, varData1)
[b]'подсчет селектированных объектов[/b]
summa = summa + objSelSet.Count
End Sub
Public Function SmatrSel(ByRef filtData() As Integer, varData As Variant) As AcadSelectionSet
Dim objSelSet As AcadSelectionSet
Dim objSelCol As AcadSelectionSets
Set objSelCol = ThisDrawing.SelectionSets
For Each objSelSet In objSelCol
If objSelSet.Name = "Test_Sel" Then
objSelSet.Delete
Exit For
End If
Next
Set objSelSet = objSelCol.Add("Test_Sel")
Dim objEnt As AcadEntity
objSelSet.Select acSelectionSetAll, , , filtData, varData
Set SmatrSel = objSelSet
End Functionlisting2
Public Sub CountOBJ()
Dim Entt As String
summa = 0
Dim ent As AcadEntity
On Error Resume Next
For Each ent In ThisDrawing.ModelSpace
Select Case ent.ObjectName
Case "AcDbPoint"
[b]'подсчет объектов[/b]
summa = summa + 1
Case "AcDb3dPolyline"
[b]'подсчет объектов[/b]
summa = summa + 1
Case "AcDbPolyline"
[b]'подсчет объектов[/b]
summa = summa + 1
Case Else
MsgBox ent.ObjectName
End Select
Next ent
MsgBox summa
End Subданные алгоритмы дают разную сумму селектированных элементов listing2, показывает правильно. Помогите разобраться в чем проблема
Возможно метод
objSelSet.Select acSelectionSetAll
выбирает все обььекты, включая обекты в пространстве листа и входяшхие в блоки
> Gogi
listing1 не находит всех объектов. в файле три вида объектов т.к.
Case Else
MsgBox ent.ObjectNameмолчит
> SmeL
listing2 Просматривает обььекты не в фаиле, а только в пространстве модели:
For Each ent In ThisDrawing.ModelSpace
Кстати Listing1 если не задан параметр asPoint ишхет точки , а не полилинии
Приношу свои извинения :) за это недоразумение. Все работает корректно просто я забыл, что я некоторые слои не должен рассматривать, listing1 это обеспечивает listing2 нет вот и вся не стыковка.
Страницы 1
Чтобы отправить ответ, вы должны войти или зарегистрироваться
Форумы CADUser → Программирование → VBA → Помогите с фильтром
Форум работает на PunBB, при поддержке Informer Technologies, Inc
