Тема: ВОПРОС К FIXO
Доброе утро!!!
А можно ли тот же самый код сделать не для значений Тагов, а для значений Валуе??? Т.е. у всех блоков одни и те же Таги, а значения Валуе разные.
Option Explicit
Const blkName As String = "ДЕТАЛЬ" ' <-- change block name
Const attName1 As String = "AT1" ' <-- change attribute tag
Const attName2 As String = "AT2" ' <-- change attribute tag
Const attValue1 As String = "0.001" ' <-- change 1st attribute value
Const attValue2 As String = "ABC" ' <-- change 2nd attribute value
'~~~~~~~~~~~~~~~~~~~~~~~~~~~'
Sub CountBlocksByAttributes()
Dim oSset As AcadSelectionSet
Dim oEnt As AcadEntity
Dim oBlkRef As AcadBlockReference
Dim oAtt As AcadAttributeReference
Dim attArr() As AcadAttributeReference
Dim attVal1 As String
Dim attVal2 As String
Dim i As Long
Dim counter As Integer
Dim ftype(1) As Integer
Dim fdata(1) As Variant
Dim dxfCode, dxfValue
On Error GoTo Err_Control
ftype(0) = 0: ftype(1) = 2
fdata(0) = "INSERT": fdata(1) = blkName
dxfCode = ftype: dxfValue = fdata
With ThisDrawing.SelectionSets
While .Count > 0
.Item(0).Delete
Wend
Set oSset = .Add("$Blocks$")
End With
oSset.Select acSelectionSetAll, , , dxfCode, dxfValue
For Each oEnt In oSset
Set oBlkRef = oEnt
attArr = oBlkRef.GetAttributes
On Error Resume Next
For i = 0 To UBound(attArr)
Set oAtt = attArr(i)
Select Case oAtt.TagString
Case "AT1"
attVal1 = oAtt.TextString
Case "AT2"
attVal2 = oAtt.TextString
End Select
Next i
If StrComp(attVal1, attValue1, vbTextCompare) = 0 And _
StrComp(attVal2, attValue2, vbTextCompare) = 0 Then
counter = counter + 1
End If
Next oEnt
If Err Then
Err.Clear
End If
MsgBox "Всего блоков с такими атрибутами: " & counter
Err_Control:
If Err.Number <> 0 Then
MsgBox Err.Description
End If
End Sub
