请问，VB如何读取cad中已经标注的尺寸

stephenhwang · 发表于 2011-3-31 14:59:00

各位前辈，小弟想实现用鼠标点取某标注尺寸，然后进行修改，如何实现？请前辈赐教

shi · 发表于 2011-5-14 12:11:00

'获取标注尺寸
Sub hqbz()
Dim SSet1 As AcadSelectionSet
Dim ct As Integer
Dim fType(0) As Integer
Dim fData(0) As Variant
fType(0) = 0
fData(0) = "DIMENSION"
On Error Resume Next
ThisDrawing.SelectionSets.Item("tes").Delete

Set SSet = ThisDrawing.SelectionSets.Add("tes")

SSet.SelectOnScreen fType, fData  '建立选择集并从屏幕选取
If SSet.Count = 0 Then
   SSet.Delete
   End
End If
ct = SSet.Count - 1
ReDim bzcc(0 To ct)

Dim i As Long
For i = 0 To ct
      bzcc(i) = FixDimMeas(SSet.Item(i)) '获取标注的尺寸到数组
Next

For i = 0 To ct - 1 '对数组排降序，采用冒泡法
   For j = 0 To ct - i - 1
      If bzcc(j) < bzcc(j + 1) Then
         swapDX = bzcc(j): bzcc(j) = bzcc(j + 1): bzcc(j + 1) = swapDX '交换
      End If
   Next j
Next i
SSet.Delete
Dim msg As String
msg = " 标注尺寸 " & vbCrLf & vbCrLf '输出标注尺寸
For n = 0 To UBound(bzcc)
   msg = msg + " " & bzcc(n) & vbCrLf
Next
msg = msg & vbCrLf + " 总数:" + Str$(n)
MsgBox  msg

stephenhwang · 发表于 2011-4-22 14:16:00

没人回答啊

为什么任兵 · 发表于 2011-4-27 14:51:00

我看到过一次，不过很高深的问题

stephenhwang · 发表于 2011-6-20 10:52:00

非常感谢！还有个问题 FixDimMeas是什么函数？

shi · 发表于 2011-7-14 14:19:00

'获取标注尺寸函数
Function FixDimMeas(Dimension As AcadDimension) As Long
Dim BlockCount As Long
Dim bz As Long

BlockCount = ThisDrawing.Blocks.Count
      '遍历块中的对象，取得标注尺寸
      Dim EntityInBlock As AcadEntity
      For Each EntityInBlock In ThisDrawing.Blocks(BlockCount - 1)
         If EntityInBlock.ObjectName = "AcDbMText" Then
               Dimension.TextColor = acWhite    '标注文字颜色设定为白色
               bz = Dimension.Measurement
               FixDimMeas = bz
            Exit For
         End If
      Next
End Function