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 "&Iuml;&Ouml;&Ocirc;&Uacute;&Auml;ú&iquest;&Eacute;&Ograve;&Ocirc;&para;&Ocirc;&Iacute;&frac14;&Atilde;&aelig;&Eacute;&Iuml;&micro;&Auml;&sup1;¤&Ograve;&Otilde;&ETH;&Aring;&Iuml;&cent;&frac12;&oslash;&ETH;&ETH;&Ecirc;&auml;&Egrave;&euml;&raquo;ò&ETH;&THORN;&cedil;&Auml;&Aacute;&Euml;!"
Retry:
    Err.Clear
    ThisDrawing.Utility.GetEntity retEnt, pnt, "&Ccedil;&euml;&Ntilde;&iexcl;&Ocirc;&ntilde;&Icirc;&iuml;&Igrave;&aring;:"
    If Err <> 0 Then
      Err.Clear
      MsgBox "&Ccedil;&euml;&Ntilde;&iexcl;&Ocirc;&ntilde;&Iuml;à&sup1;&Oslash;&micro;&Auml;&Ecirc;&micro;&Igrave;&aring;&frac12;&oslash;&ETH;&ETH;&sup2;&Ugrave;×÷!"
      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 = "&Ouml;±&frac34;&para;" & NewRecord.BD
                                        If retEnt.EntityName = "AcDbRadialDimension" Then MeasureValue = "R" & NewRecord.BD
                              Else
                                        If retEnt.EntityName = "AcDbDiametricDimension" Then MeasureValue = "&Ouml;±&frac34;&para;" & 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) & "&para;&Egrave;"
                              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"
                            '&Egrave;&ccedil;&sup1;&ucirc;&Ntilde;&iexcl;&Ocirc;&ntilde;&micro;&Auml;&Ecirc;&Ccedil;&iquest;é&Ograve;&yacute;&Oacute;&Atilde;&pound;&not;&frac12;&laquo;&AElig;&auml;&cedil;&sup3;&cedil;&oslash;&iquest;é&Ograve;&yacute;&Oacute;&Atilde;&para;&Ocirc;&Iuml;ó
                            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 = "&acute;&Ouml;&sup2;&Uacute;&para;&Egrave;" & 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("&Auml;&atilde;&ETH;è&Ograve;&ordf;&Ntilde;&iexcl;&Ocirc;&ntilde;&Ograve;&raquo;&cedil;&ouml;&Ecirc;&micro;&Igrave;&aring;&frac12;&oslash;&ETH;&ETH;&sup2;&Ugrave;×÷!" & vbCrLf & _
                                       "&frac14;&Igrave;&ETH;&oslash;&Ecirc;&auml;&Egrave;&euml;&sup1;¤&Ograve;&Otilde;&ETH;&Aring;&Iuml;&cent;°&acute;&Egrave;·&para;¨&frac14;ü,&Iacute;&Euml;&sup3;&ouml;&sup1;¤&Ograve;&Otilde;&ETH;&Aring;&Iuml;&cent;°&acute;&Egrave;&iexcl;&Iuml;&ucirc;!", vbOKCancel, "&sup1;¤&Ograve;&Otilde;&ETH;&Aring;&Iuml;&cent;&Ecirc;&auml;&Egrave;&euml;")
            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里可以显示正确,但复制&Oslash;就变成了?, ±⊥∥∠可以复制,
其他形位公差的符号怎么办呀?

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

形位公差的符号其它也是一种字体，你可以查看gdt.shp，公差符号全部在里边。
代表的字符如下：
位置度：j
同轴度：r
对称度：i
平行度：f
垂直度：b
倾斜度：a
圆柱度：g
平面度：c
圆度：e
直线度：u
面轮廓度：d
线轮廓度：k
圆跳动度：h
全跳动度：t
页: [1]
查看完整版本: 有没有更好的方法读出尺寸文字和块的信息?