有没有更好的方法读出尺寸文字和块的信息?

lei_jinbo · 发表于 2003-9-25 10:12:00

我要求选择一个物体后,读出图面标注的实际信息:

Retry:
Err.Clear
ThisDrawing.Utility.GetEntity retEnt, pnt, "ÇëÑ¡ÔñÎïÌå:"
If Err <> 0 Then
      Err.Clear
      MsgBox "please choose an object again"
      GoTo Retry
Else

   Select Case retEnt.EntityName
  Case "AcDbAlignedDimension", "AcDbRotatedDimension", "AcDbRadialDimension", "AcDbDiametricDimension",  "AcDbOrdinateDimension", "AcDb2LineAugularDimension"

         MeasureValue = retEnt.Measurement
         TxtOverride = retEnt.TextOverride
         If TxtOverride = "" Then
               MsgBox retEnt.TolerancePrecision
               NewRecord.BD = Format(MeasureValue, "0.00")  ' 格式改怎么和精度对应,我知道可以写子程序,还有其他办法吗?
               NewRecord.Ut = retEnt.ToleranceUpperLimit
               NewRecord.Lt = -retEnt.ToleranceLowerLimit
         Else
               NewRecord.BD = TxtOverride ' 对于默认的尺寸<>怎么求出?
         End If

      Case "AcDbMText", "AcDbText"
               NewRecord.BD = retEnt.TextString
      Case "AcDbBlockreference"
               '读出块信息,比如粗糙度改怎么写?
      Case Else
               GoTo retry
      End Select

mccad · 发表于 2003-9-25 20:42:00

Measurement 为标注的测量尺寸，也就是标注的实际尺寸。
TextOverride 是替代的尺寸，如果尺寸是默认的而没有修改过，则该值为""，如果该值为<>时则使用Measurement中的值。
精度的值在 PrimaryUnitsPrecision 属性中，其值其实为整数，代表小数点后的位数。
公差精度的位数在TolerancePrecision 属性中，其值其实为整数，代表小数点后的位数。
所以以上两个精度可以通过写一个函数来取得，你自己写吧(不行的话我再帮你写)。
对于块中的信息，如果你一个块中只有一个文本，你可以取得文本的值，如果一个块中有多个文本，你就必须使用一个扩展数据来做标记，如果你使用的是带属性的块，那就方便了，你只有取得某个属性的值就行。

lei_jinbo · 发表于 2003-9-27 16:57:00

谢谢版主答复, 不过还有一个问题.
就是对半径和直径的处理,如果没有公差,可以读Measurement,可是如果有公差值,就变成了要通过textoverride才有文本,而这个文本里面是"<>{}{\H0.71X;\C3;\S+0.2~-0.3;}", 那么我怎么把基本值读出来.就是<>, measurement是空的.

mccad · 发表于 2003-9-27 20:15:00

我试过怎么是倒过来的呢？

Sub gdim()
Dim ent As AcadDimRadial
Dim pnt As Variant
ThisDrawing.Utility.GetEntity ent, pnt
Debug.Print "measurement=" & ent.Measurement
Debug.Print "textoverride=" & ent.TextOverride
End Sub

试过后是这样的：
measurement=9.44588523452155
textoverride=

lei_jinbo · 发表于 2003-9-29 08:53:00

谢谢版主,我已经写出来了. 尺寸识别考虑了以text,mtext和有公差,没公差,提取内容方式不一样.

Function PreciseTransfer(preciseLong As Integer) As String
      Select Case preciseLong
                  Case 0: PreciseTransfer = "0"
                  Case 1: PreciseTransfer = "0.0"
                  Case 2: PreciseTransfer = "0.00"
                  Case 3: PreciseTransfer = "0.000"
                  Case 4: PreciseTransfer = "0.0000"
                  Case 5: PreciseTransfer = "0.00000"
                  Case 6: PreciseTransfer = "0.000000"
                  Case 7: PreciseTransfer = "0.0000000"
                  Case 8: PreciseTransfer = "0.00000000"
      End Select
End Function
Function blnTolerance(txt As String) As Boolean
      Dim ps As Integer, i As Integer
      Dim Defaultsymbol As String
      For i = 1 To Len(txt) - 3
            If Mid(txt, i, 1) = "<" And Mid(txt, i + 1, 1) = ">" And Mid(txt, i + 2, 1) = "{" And Mid(txt, i + 3, 1) = "}" Then
               blnTolerance = True
               Exit For
            Else
               blnTolerance = False
            End If
      Next i
End Function
Sub inputProcessInformation()
Dim retEnt As Object
Dim pnt As Variant
Dim MeasureValue As String, TxtOverride As String, dPrecise As String, tPrecise
Dim blkRefObj As AcadBlockReference
On Error Resume Next

' The following example waits for a input from user and returns the Line in retEnt
MsgBox "ÏÖÔÚÄú¿ÉÒÔ¶ÔÍ¼ÃæÉÏµÄ¹¤ÒÕÐÅÏ¢½øÐÐÊäÈë»òÐÞ¸ÄÁË!"
Retry:
Err.Clear
ThisDrawing.Utility.GetEntity retEnt, pnt, "ÇëÑ¡ÔñÎïÌå:"
If Err <> 0 Then
      Err.Clear
      MsgBox "ÇëÑ¡ÔñÏà¹ØµÄÊµÌå½øÐÐ²Ù×÷!"
      GoTo Retry
Else

      NewRecord.ID = retEnt.ObjectID
   Select Case retEnt.EntityName
      Case "AcDbAlignedDimension", "AcDbRotatedDimension", "AcDbOrdinateDimension", "AcDbDiametricDimension", "AcDbRadialDimension"
                     MeasureValue = retEnt.Measurement
                     TxtOverride = retEnt.TextOverride
                     ' judge whether the dimension is text or real dimension, if txt , txtoverride<>""
                     If TxtOverride = "" Then
                              ' get the real dimension information
                              dPrecise = PreciseTransfer(retEnt.PrimaryUnitsPrecision)
                              NewRecord.BD = Format(MeasureValue, dPrecise)
                              If retEnt.EntityName = "AcDbDiametricDimension" Then NewRecord.BD = "?" & NewRecord.BD
                              If retEnt.EntityName = "AcDbRadialDimension" Then NewRecord.BD = "R" & NewRecord.BD

                              tPrecise = ret.TolerancePrecision
                              NewRecord.Ut = Format(retEnt.ToleranceUpperLimit, tPrecise)
                              NewRecord.Lt = Format(-retEnt.ToleranceLowerLimit, tPrecise)
                              If NewRecord.Ut = 0 And NewRecord.Lt = 0 Then
                                    NewRecord.Ut = ""
                                    NewRecord.Lt = ""
                              End If
                     Else
                              ' if it is mtext/text method to produce the dimension and the tolerance exists.
                              dPrecise = PreciseTransfer(retEnt.PrimaryUnitsPrecision)
                              MeasureValue = Format(MeasureValue, dPrecise)
                              If blnTolerance(TxtOverride) = True Then
                                       tPrecise = PreciseTransfer(retEnt.TolerancePrecision)
                                    NewRecord.Ut = Format(retEnt.ToleranceUpperLimit, tPrecise)
                                    NewRecord.Lt = Format(-retEnt.ToleranceLowerLimit, tPrecise)
                                    NewRecord.BD = MeasureValue
                                    If retEnt.EntityName = "AcDbDiametricDimension" Then MeasureValue = "Ö±¾¶" & NewRecord.BD
                                    If retEnt.EntityName = "AcDbRadialDimension" Then MeasureValue = "R" & NewRecord.BD
                              Else
                                    If retEnt.EntityName = "AcDbDiametricDimension" Then MeasureValue = "Ö±¾¶" & MeasureValue
                                    If retEnt.EntityName = "AcDbRadialDimension" Then MeasureValue = "R" & MeasureValue
                                    NewRecord.BD = Replace(TxtOverride, "<>", MeasureValue)
                              End If
                     End If

      Case "AcDb2LineAngularDimension"
                  ' change the unit of angle
               MeasureValue = retEnt.Measurement
               MeasureValue = MeasureValue * 180 / 3.1415926
               TxtOverride = retEnt.TextOverride
                     ' judge whether the dimension is text or real dimension, if txt , txtoverride<>""
                     If TxtOverride = "" Then
                              ' get the real dimension information
                              dPrecise = PreciseTransfer(retEnt.TextPrecision)
                              NewRecord.BD = Format(MeasureValue, dPrecise) & "¶È"
                              NewRecord.Ut = Format(retEnt.ToleranceUpperLimit, tPrecise)
                              NewRecord.Lt = Format(-retEnt.ToleranceLowerLimit, tPrecise)
                              If NewRecord.Ut = 0 And NewRecord.Lt = 0 Then
                                    NewRecord.Ut = ""
                                    NewRecord.Lt = ""
                              End If
                     Else
                              ' if it is mtext/text method to produce the dimension and the tolerance exists.
                              dPrecise = PreciseTransfer(retEnt.TextPrecision)
                              MeasureValue = Format(MeasureValue, dPrecise)
                              If blnTolerance(TxtOverride) = True Then
                                    tPrecise = PreciseTransfer(retEnt.TolerancePrecision)
                                    NewRecord.Ut = Format(retEnt.ToleranceUpperLimit, tPrecise)
                                    NewRecord.Lt = Format(-retEnt.ToleranceLowerLimit, tPrecise)
                                    NewRecord.BD = MeasureValue
                              Else
                                    NewRecord.BD = Replace(TxtOverride, "<>", MeasureValue)
                              End If
                     End If

      Case "AcDbMText", "AcDbText"
            NewRecord.BD = retEnt.TextString
            NewRecord.Ut = ""
            NewRecord.Lt = ""

      Case "AcDbBlockReference"
                        'Èç¹ûÑ¡ÔñµÄÊÇ¿éÒýÓÃ£¬½«Æä¸³¸ø¿éÒýÓÃ¶ÔÏó
                        Set blkRefObj = retEnt
                        Dim attVars As Variant
                        Dim i As Integer
                        If blkRefObj.Name = "RRR" Or blkRefObj.Name = "RRL" Then
                                 attVars = blkRefObj.GetAttributes
                                 NewRecord.BD = "´Ö²Ú¶È" & attVars(0).TextString
                                 MsgBox NewRecord.BD
                        ElseIf blkRefObj.Name = "RZU" Or blkRefObj.Name = "RZL" Then
                                 NewRecord.BD = "Rz200"
                        Else
                                 GoTo ChooseReply
                        End If
      Case "AcDbFcf"
                  Dim tol As AcadTolerance
                  Set tol = retEnt
                  MsgBox tol.TextString
                  GoTo Retry
      Case Else
               'GoTo ChooseReply

               MsgBox retEnt.EntityName
      End Select

      frminputprocessinformation.pShow

ChooseReply:    ' reply the process until the user choose to cancel.
      strmsg = MsgBox("ÄãÐèÒªÑ¡ÔñÒ»¸öÊµÌå½øÐÐ²Ù×÷!" & vbCrLf & _
                                       "¼ÌÐøÊäÈë¹¤ÒÕÐÅÏ¢°´È·¶¨¼ü,ÍË³ö¹¤ÒÕÐÅÏ¢°´È¡Ïû!", vbOKCancel, "¹¤ÒÕÐÅÏ¢ÊäÈë")
         If strmsg = vbOK Then
            GoTo Retry
         Else
            Exit Sub
         End If
   End If
End Sub

不过,还有问题请帮主帮忙:
1). 对于直径,度数,还有形位公差符号,的这些字符如果从WORD里面复制到VBA界面,就变成了问号.而我在写程序时要用到,怎么办?
2)对应形位公差的部分,TEXTSTRING的属性提取出来的信息好像要写子程序识别才行.有没有好的简单办法.

谢谢!

mccad · 发表于 2003-9-29 14:11:00

1.不知你编程用什么系统，怎么粘贴上来的内容都是乱码？
2.直径度数和正负号在CAD的SHX字体中有具体代表的代码，而WORD是实际的字符，所以要先转换。
3.形位公差的TextString属性部分是要写函数来提取。

lei_jinbo · 发表于 2003-9-29 15:48:00

1.对不起,乱码部分是汉字,
2.Textstring我会写一个子程序来提取,
3.但是对于字符问题,我还是想不出办法.
我在WORD里面复制˚到VBA里可以显示正确,但复制Ø就变成了?, ±⊥∥∠可以复制,
其他形位公差的符号怎么办呀?

mccad · 发表于 2003-9-29 15:58:00

形位公差的符号其它也是一种字体，你可以查看gdt.shp，公差符号全部在里边。
代表的字符如下：
位置度：j
同轴度：r
对称度：i
平行度：f
垂直度：b
倾斜度：a
圆柱度：g
平面度：c
圆度：e
直线度：u
面轮廓度：d
线轮廓度：k
圆跳动度：h
全跳动度：t

账号		自动登录	找回密码
密码			注册