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

stephenhwang

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

shi

'获取标注尺寸
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

没人回答啊

为什么任兵

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

stephenhwang

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

shi

'获取标注尺寸函数
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

conqibo

回复 shi 的帖子

请问如何 导入到txt文件中，且小数点后面两位有效数字啊？

jsxygshh

shi 发表于 2011-7-14 14:19
'获取标注尺寸函数
Function FixDimMeas(Dimension As AcadDimension) As Long
    Dim BlockCount As Lo ...

vb6.0，cad2008，xp系统下，调试不成功呀
请解释一下，在VBA中成功

jsxygshh

盼楼主给予解答

CAD83

分清VB和VBA的区别