Добавление атрибута и сортировка блоков по имени и по атрибутам (Страница 1 из 2)

Option Explicit
Dim oSset As AcadSelectionSet
Dim oEnt As AcadEntity
Dim oBlkRef As AcadBlockReference
Dim bname As String
Dim atts As Variant
Dim i As Integer
Private Sub cmdExit_Click()
Unload Me
End Sub
Private Sub cmdSelect_Click()
Dim varpt
Me.Hide
On Error Resume Next
ThisDrawing.Utility.GetEntity oEnt, varpt, vbCrLf & "Выбрать блок"
If Err Then
MsgBox "Nothing selected"
Exit Sub
End If
If Not TypeOf oEnt Is AcadBlockReference Then
MsgBox "Wrong object selected"
Exit Sub
End If
Set oBlkRef = oEnt
If oBlkRef.IsDynamicBlock Then
bname = oBlkRef.EffectiveName & "," & "`*U*"
Else
bname = oBlkRef.Name
End If
If oBlkRef.HasAttributes Then
Dim oAtt As AcadAttributeReference
atts = oBlkRef.GetAttributes
For i = LBound(atts) To UBound(atts)
Set oAtt = atts(i)
Me.cbxAttributes.AddItem oAtt.TextString
Next
End If
Call GetDinamicProps(oBlkRef, "Земля")
Me.Show
End Sub
Private Sub cmdUpdate_Click()
  If Me.cbxAttributes.Text = "" Then
  MsgBox "You forgot to select" & vbCr & "attribute value in combobox"
  Exit Sub
  End If
  If Me.txtNewValue = "" Then
  MsgBox "You forgot to enter" & vbCr & "new attribute value in textbox"
  Exit Sub
  End If
  If Me.cbxDynProps = "" Then
  MsgBox "You forgot to enter" & vbCr & "dynamic prperty value in combobox"
  Exit Sub
  End If
      For i = LBound(atts) To UBound(atts)
        If atts(i).TextString = cbxAttributes.Text Then
          atts(i).TextString = txtNewValue.Text
        End If
      Next i
  Dim props() As AcadDynamicBlockReferenceProperty
  props = oBlkRef.GetDynamicBlockProperties
  Dim prop As AcadDynamicBlockReferenceProperty
For i = LBound(props) To UBound(props)
Set prop = props(i)
If prop.PropertyName = "Земля" Then
prop.Value = Me.cbxDynProps.Text
End If
Next i
  ThisDrawing.Regen acActiveViewport
  txtNewValue.Text = ""
  cbxAttributes.Clear
  cbxDynProps.Clear
  cmdUpdateAll.Enabled = False
  cmdExit.SetFocus
End Sub
Private Sub cmdUpdateAll_Click()
  On Error GoTo Err_Control
  Dim cnt As Integer
  Call GetBlockInstances(bname)
  If Me.cbxAttributes.Text = "" Then
  MsgBox "You forgot to select" & vbCr & "attribute value in combobox"
  Exit Sub
  End If
  If Me.txtNewValue = "" Then
  MsgBox "You forgot to enter" & vbCr & "new attribute value in textbox"
  Exit Sub
  End If
  If Me.cbxDynProps = "" Then
  MsgBox "You forgot to enter" & vbCr & "dynamic prperty value in combobox"
  Exit Sub
  End If
  For Each oEnt In oSset
  Set oBlkRef = oEnt
  atts = oBlkRef.GetAttributes
      For i = LBound(atts) To UBound(atts)
        If atts(i).TextString = cbxAttributes.Text Then
          atts(i).TextString = txtNewValue.Text
        End If
      Next i
  Dim props() As AcadDynamicBlockReferenceProperty
  props = oBlkRef.GetDynamicBlockProperties
  Dim prop As AcadDynamicBlockReferenceProperty
For i = LBound(props) To UBound(props)
Set prop = props(i)
If prop.PropertyName = "Земля" Then
prop.Value = Me.cbxDynProps.Text
End If
Next i
      cnt = cnt + 1
 Next oEnt
  Me.Caption = "There are " & cnt & " blocks changed"
  ThisDrawing.Regen acActiveViewport
  txtNewValue.Text = ""
  cbxAttributes.Clear
  cbxDynProps.Clear
    cmdUpdate.Enabled = False
  cmdExit.SetFocus
Err_Control:
If Err.Number <> 0 Then
  MsgBox Err.Description
  Err.Clear
  End If
End Sub
Private Sub UserForm_Initialize()
Me.cmdUpdate.Enabled = True
Me.cmdUpdateAll.Enabled = True
Me.cbxAttributes.Clear
End Sub
Sub GetBlockInstances(bname As String)
     Dim ftype(1) As Integer
     Dim fdata(1) As Variant
     Dim dxfCode, dxfValue
          With ThisDrawing.SelectionSets
               While .count > 0
                    .Item(0).Delete
               Wend
          End With
     With ThisDrawing.SelectionSets
          Set oSset = .Add("$Blocks$")
     End With
     ftype(0) = 0: ftype(1) = 2
     fdata(0) = "INSERT": fdata(1) = bname
     dxfCode = ftype: dxfValue = fdata
     oSset.Select acSelectionSetAll, , , dxfCode, dxfValue
End Sub
Sub GetDinamicProps(blkRef As AcadBlockReference, propName As String)
Dim props() As AcadDynamicBlockReferenceProperty
Dim i As Integer
Dim j As Integer
Dim pvalue As Variant
Dim itm As Object
props = blkRef.GetDynamicBlockProperties
Dim prop As AcadDynamicBlockReferenceProperty
For i = LBound(props) To UBound(props)
Set prop = props(i)
If prop.PropertyName = propName Then
pvalue = prop.AllowedValues
For j = 0 To UBound(pvalue)
cbxDynProps.AddItem pvalue(j)
Next j
End If
Next i
End Sub

Option Explicit
Sub runme()
Dim frm As UserForm1
Set frm = New UserForm1
frm.Show
End Sub