坐标标注

qq2222081387

坐标标注   X Y坐标都可用   

[pcode=vb,true]

' 在模型空间中创建坐标标注。
Public Sub pc_zb()
    On Error Resume Next

    Dim dimObj As AcadDimOrdinate
    Dim pT0 As Variant
    Dim pT As Variant
    Dim pTyd(0 To 2) As Double
    Dim pTs(0 To 2) As Double
    Dim pTe(0 To 2) As Double
    Dim fx As Boolean

    fx = True
    pTyd(0) = 0: pTyd(1) = 0: pTyd(2) = 0
    pT0 = ThisDrawing.Utility.GetPoint(, "坐标起点: ")

    Dim j_xxs As Double, j_yxs As Double, j_wzxs As Boolean
    j_wzxs = True
    '获取标注的全局比例
    Dim RetVal As Variant
    RetVal = ThisDrawing.GetVariable("dimscale")
    j_xxs = 0: j_yxs = RetVal * 10

    ' 在模型空间中创建起点坐标标注
    pTs(0) = 0: pTs(1) = 0: pTs(2) = 0
    pTe(0) = j_xxs: pTe(1) = j_yxs: pTe(2) = 0
    Set dimObj = ThisDrawing.ModelSpace.AddDimOrdinate(pTs, pTe, fx)
    dimObj.Layer = "标注"
    dimObj.Move pTyd, pT0

     '设置关键字
    ThisDrawing.Utility.InitializeUserInput 1, "X Y T"
    Do
        pT = ThisDrawing.Utility.GetPoint(pT0, "[X]标注X坐标,[Y]标注Y坐标,[T]变换文字位置,选取下一点: ")
        If Err Then
            If InStr(1, Err.Description, "关键字", vbTextCompare) > 0 Or _
                InStr(1, Err.Description, "keyword", vbTextCompare) > 0 Then '输入了一个关键字
                Dim inputString As String
                Err.Clear
                inputString = ThisDrawing.Utility.GetInput
                Select Case inputString
                    Case "X"
                        fx = True
                        If j_wzxs Then
                            j_xxs = 0: j_yxs = RetVal * 10
                        Else
                            j_xxs = 0: j_yxs = 0 - RetVal * 10
                        End If
                    Case "Y"
                        fx = False
                        If j_wzxs Then
                            j_xxs = RetVal * 10: j_yxs = 0
                        Else
                            j_xxs = 0 - RetVal * 10: j_yxs = 0
                        End If
                    Case "T"
                        j_wzxs = Not j_wzxs
                        j_xxs = 0 - j_xxs: j_yxs = 0 - j_yxs
                End Select
            Else
                Err.Clear
                Exit Sub  '错误退出
            End If
        Else
            pTs(0) = pT(0) - pT0(0): pTs(1) = pT(1) - pT0(1): pTs(2) = 0
            pTe(0) = pTs(0) + j_xxs: pTe(1) = pTs(1) + j_yxs: pTe(2) = 0
            Set dimObj = ThisDrawing.ModelSpace.AddDimOrdinate(pTs, pTe, fx)
                dimObj.Layer = "标注"
                dimObj.Move pTyd, pT0
        End If
    Loop
End Sub

[/pcode]

qq2222081387

为什么不是高亮显示

1. ' 在模型空间中创建坐标标注。
   
2. Public Sub pc_zb()
   
3.     On Error Resume Next
   
4.    
   
5.     Dim dimObj As AcadDimOrdinate
   
6.     Dim pT0 As Variant
   
7.     Dim pT As Variant
   
8.     Dim pTyd(0 To 2) As Double
   
9.     Dim pTs(0 To 2) As Double
   
10.     Dim pTe(0 To 2) As Double
    
11.     Dim fx As Boolean
    
12.    
    
13.     fx = True
    
14.     pTyd(0) = 0: pTyd(1) = 0: pTyd(2) = 0
    
15.     pT0 = ThisDrawing.Utility.GetPoint(, "坐标起点: ")
    
16.    
    
17.     Dim j_xxs As Double, j_yxs As Double, j_wzxs As Boolean
    
18.     j_wzxs = True
    
19.     '获取标注的全局比例
    
20.     Dim RetVal As Variant
    
21.     RetVal = ThisDrawing.GetVariable("dimscale")
    
22.     j_xxs = 0: j_yxs = RetVal * 10
    
23.    
    
24.     ' 在模型空间中创建起点坐标标注
    
25.     pTs(0) = 0: pTs(1) = 0: pTs(2) = 0
    
26.     pTe(0) = j_xxs: pTe(1) = j_yxs: pTe(2) = 0
    
27.     Set dimObj = ThisDrawing.ModelSpace.AddDimOrdinate(pTs, pTe, fx)
    
28.     dimObj.Layer = "标注"
    
29.     dimObj.Move pTyd, pT0
    
30.    
    
31.      '设置关键字
    
32.     ThisDrawing.Utility.InitializeUserInput 1, "X Y T"
    
33.     Do
    
34.         pT = ThisDrawing.Utility.GetPoint(pT0, "[X]标注X坐标,[Y]标注Y坐标,[T]变换文字位置,选取下一点: ")
    
35.         If Err Then
    
36.             If InStr(1, Err.Description, "关键字", vbTextCompare) > 0 Or _
    
37.                 InStr(1, Err.Description, "keyword", vbTextCompare) > 0 Then '输入了一个关键字
    
38.                 Dim inputString As String
    
39.                 Err.Clear
    
40.                 inputString = ThisDrawing.Utility.GetInput
    
41.                 Select Case inputString
    
42.                     Case "X"
    
43.                         fx = True
    
44.                         If j_wzxs Then
    
45.                             j_xxs = 0: j_yxs = RetVal * 10
    
46.                         Else
    
47.                             j_xxs = 0: j_yxs = 0 - RetVal * 10
    
48.                         End If
    
49.                     Case "Y"
    
50.                         fx = False
    
51.                         If j_wzxs Then
    
52.                             j_xxs = RetVal * 10: j_yxs = 0
    
53.                         Else
    
54.                             j_xxs = 0 - RetVal * 10: j_yxs = 0
    
55.                         End If
    
56.                     Case "T"
    
57.                         j_wzxs = Not j_wzxs
    
58.                         j_xxs = 0 - j_xxs: j_yxs = 0 - j_yxs
    
59.                 End Select
    
60.             Else
    
61.                 Err.Clear
    
62.                 Exit Sub  '错误退出
    
63.             End If
    
64.         Else
    
65.             pTs(0) = pT(0) - pT0(0): pTs(1) = pT(1) - pT0(1): pTs(2) = 0
    
66.             pTe(0) = pTs(0) + j_xxs: pTe(1) = pTs(1) + j_yxs: pTe(2) = 0
    
67.             Set dimObj = ThisDrawing.ModelSpace.AddDimOrdinate(pTs, pTe, fx)
    
68.                 dimObj.Layer = "标注"
    
69.                 dimObj.Move pTyd, pT0
    
70.         End If
    
71.     Loop
    
72. End Sub

' 在模型空间中创建坐标标注。<br /> Public Sub pc_zb()<br />     On Error Resume Next<br />     <br />     Dim dimObj As AcadDimOrdinate<br />     Dim pT0 As Variant<br />     Dim pT As Variant<br />     Dim pTyd(0 To 2) As Double<br />     Dim pTs(0 To 2) As Double<br />     Dim pTe(0 To 2) As Double<br />     Dim fx As Boolean<br />     <br />     fx = True<br />     pTyd(0) = 0: pTyd(1) = 0: pTyd(2) = 0<br />     pT0 = ThisDrawing.Utility.GetPoint(, "坐标起点: ")<br />     <br />     Dim j_xxs As Double, j_yxs As Double, j_wzxs As Boolean<br />     j_wzxs = True<br />     '获取标注的全局比例<br />     Dim RetVal As Variant<br />     RetVal = ThisDrawing.GetVariable("dimscale")<br />     j_xxs = 0: j_yxs = RetVal * 10<br />     <br />     ' 在模型空间中创建起点坐标标注<br />     pTs(0) = 0: pTs(1) = 0: pTs(2) = 0<br />     pTe(0) = j_xxs: pTe(1) = j_yxs: pTe(2) = 0<br />     Set dimObj = ThisDrawing.ModelSpace.AddDimOrdinate(pTs, pTe, fx)<br />     dimObj.Layer = "标注"<br />     dimObj.Move pTyd, pT0<br />     <br />      '设置关键字<br />     ThisDrawing.Utility.InitializeUserInput 1, "X Y T"<br />     Do<br />         pT = ThisDrawing.Utility.GetPoint(pT0, "[X]标注X坐标,[Y]标注Y坐标,[T]变换文字位置,选取下一点: ")<br />         If Err Then<br />             If InStr(1, Err.Description, "关键字", vbTextCompare) > 0 Or _<br />                 InStr(1, Err.Description, "keyword", vbTextCompare) > 0 Then '输入了一个关键字<br />                 Dim inputString As String<br />                 Err.Clear<br />                 inputString = ThisDrawing.Utility.GetInput<br />                 Select Case inputString<br />                     Case "X"<br />                         fx = True<br />                         If j_wzxs Then<br />                             j_xxs = 0: j_yxs = RetVal * 10<br />                         Else<br />                             j_xxs = 0: j_yxs = 0 - RetVal * 10<br />                         End If<br />                     Case "Y"<br />                         fx = False<br />                         If j_wzxs Then<br />                             j_xxs = RetVal * 10: j_yxs = 0<br />                         Else<br />                             j_xxs = 0 - RetVal * 10: j_yxs = 0<br />                         End If<br />                     Case "T"<br />                         j_wzxs = Not j_wzxs<br />                         j_xxs = 0 - j_xxs: j_yxs = 0 - j_yxs<br />                 End Select<br />             Else<br />                 Err.Clear<br />                 Exit Sub  '错误退出<br />             End If<br />         Else<br />             pTs(0) = pT(0) - pT0(0): pTs(1) = pT(1) - pT0(1): pTs(2) = 0<br />             pTe(0) = pTs(0) + j_xxs: pTe(1) = pTs(1) + j_yxs: pTe(2) = 0<br />             Set dimObj = ThisDrawing.ModelSpace.AddDimOrdinate(pTs, pTe, fx)<br />                 dimObj.Layer = "标注"<br />                 dimObj.Move pTyd, pT0<br />         End If<br />     Loop<br /> End Sub

hch8682005

谢谢!学习学习！