[CASS二次开发源代码]VBA+AutoCAD---高程点处理

Sub SetGcdHeightByLabel()'根据高程点注记修改高程点高程值
  Dim sSet As AcadSelectionSet
  Dim dType(0 To 2) As Integer, dData(0 To 2) As Variant
  Dim objBlock As AcadBlockReference, iCount As Integer
  Dim varAttributes As Variant, pnt As Variant, i As Integer
  dType(0) = 0: dData(0) = "INSERT"
  dType(1) = 2: dData(1) = "GC200"
  dType(2) = 8: dData(2) = "GCD"
  Set sSet = ThisDrawing.Application.ActiveDocument.SelectionSets.Add("GCD")
  sSet.Select acSelectionSetAll, , , dType, dData
  If sSet.Count = 0 Then
     MsgBox "图形中未发现高程点。", vbInformation, "修改高程点高程值"
  Else
     For Each objBlock In sSet
         varAttributes = objBlock.GetAttributes
         pnt = objBlock.InsertionPoint
         pnt(2) = CDbl(varAttributes(0).TextString)
         objBlock.InsertionPoint = pnt
         i = i + 1
         ThisDrawing.Application.ActiveDocument.Utility.Prompt vbCr & vbCr & "已完成 " & i & "/" & sSet.Count & " ..."
     Next
  End If
  sSet.Delete
End Sub

Sub SetGcdLabelByHeight()'根据高程点高程值修改高程点注记
  Dim sSet As AcadSelectionSet
  Dim dType(0 To 2) As Integer, dData(0 To 2) As Variant
  Dim objBlock As AcadBlockReference, iCount As Integer
  Dim varAttributes As Variant, pnt As Variant, i As Integer
  dType(0) = 0: dData(0) = "INSERT"
  dType(1) = 2: dData(1) = "GC200"
  dType(2) = 8: dData(2) = "GCD"
  Set sSet = ThisDrawing.Application.ActiveDocument.SelectionSets.Add("GCD")
  sSet.Select acSelectionSetAll, , , dType, dData
  If sSet.Count = 0 Then
     MsgBox "图形中未发现高程点。", vbInformation, "修改高程点注记"
  Else
     For Each objBlock In sSet
         varAttributes = objBlock.GetAttributes
         varAttributes(0).TextString = objBlock.InsertionPoint(2)
         i = i + 1
         ThisDrawing.Application.ActiveDocument.Utility.Prompt vbCr & vbCr & "已完成 " & i & "/" & sSet.Count & " ..."
     Next
  End If
  sSet.Delete
End Sub