[下载]：提供坐标标注的VB源代码！

misters

上传的工程有问题，就一个工程文件，其它什么都没有，是不是传错了？
建议重新上传附件。

ndy888

'这个小程序是自己用VB6编的（稍作调整可用于VBA），用来标注坐标（适用于规划、测量学，XY坐标互换），最后将文字与引线合并为一个匿名组。里面有些是全局变量，有的可能忘记修改了，有的没有赋值，用的时候仔细修改一遍才行。

2.     public acadApp As Object
   
3.     public acadDoc As Object
   
4.     public utilObj As Object
   
5.     Public moSpace As Object
   
6.    
   
7. Private Sub cmdLeader_Click()
   
8.     Dim vattmpPnt1 As Variant  '标注点
   
9.     Dim vattmpPnt2 As Variant  '起始点
   
10. 
    
11.     Dim strPntXYFormatted(0 To 1) As String '格式化以后的XY坐标，字符串
    
12.     Dim blnRightDirection As Boolean
    
13.     Dim dblLeaderPLineVertex(0 To 5) As Double '标注引线顶点坐标
    
14.     Dim dblOriginPnt(0 To 2) As Double '坐标原点
    
15.     Dim dblStartPnt(0 To 2) As Double
    
16.     Dim dblEndpnt(0 To 2) As Double
    
17.    
    
18.     Dim vatPntMin As Variant
    
19.     '包围盒左下角坐标，用于确定文字长度，否则引线长度与引线不匹配
    
20.     Dim vatPntMax As Variant
    
21.     Dim objBlock As Object
    
22.     Dim objPLine As Object
    
23.     Dim objAtt As Object
    
24.    
    
25.     Dim blnFoundIt As Boolean
    
26.     Dim vatAttVars As Variant
    
27. 
    
28.     Dim dbltmpTH As Double '标注文字高度
    
29.    
    
30.     Dim objPntGroup As Object '组对象
    
31.     Dim objtmpArray(0 To 1) As Object '加入到组的所有对象
    
32.     dim  strFormat as string  '坐标文本格式
    
33. 
    
34.     Const dblconTextRiseRatio As Double = 0.3! '引线上部坐标向上便宜数量
    
35.     Const dblconTextFallRatio As Double = -1.3!
    
36.     Const strConstLeaderBlock As String = "BLK_Leader"  '图块名称
    
37.     '可以不用图块，不过用图块有其优越的地方，特别是以后自己的软件需要对其读写的时候
    
38. 
    
39.     On Error Resume Next
    
40.     Set acadApp = GetObject(, "AutoCAD.Application.14")
    
41.     If Err Then
    
42.         Err.Clear
    
43.         Set acadApp = CreateObject("AutoCAD.Application.14")
    
44.     End If
    
45.     Set acadDoc = acadApp.ActiveDocument
    
46.     Set utilObj = acadDoc.Utility
    
47.     Set moSpace = acadDoc.ModelSpace
    
48. 
    
49.     strFormat="###0.00" '坐标格式化样式，可以把123表示为123.00
    
50.     Me.Hide
    
51.    
    
52.     dbltmpTH = MdblTextHeight * (MdblPlotRatio)   'MdblTextHeight是1：1时字高，全局变量，需要另外赋值，
    
53.     'MdblPlotRatio为图纸比例，全局变量，需要另外赋值，dbltmpTH为实际字高，也可以根据自己的要求设置
    
54.     dblOriginPnt(0) = 0#
    
55.     dblOriginPnt(1) = 0#
    
56.     dblOriginPnt(2) = 0#
    
57.     dblStartPnt(2) = 0#
    
58.     dblEndpnt(2) = 0#
    
59.    
    
60.     blnFoundIt = False
    
61.     For Each objBlock In acadDoc.Blocks
    
62.         If StrComp(UCase(objBlock.Name), UCase(strConstLeaderBlock), 1) = 0 Then
    
63.             blnFoundIt = True
    
64.             Exit For
    
65.         End If
    
66.     Next objBlock '查找有没有图块"BLK_LEADER"
    
67.    
    
68.     MstrKeyWordList = "X eXit"
    
69.     Do While 1
    
70.         Call ChangeOSNAP(True)  '打开捕捉模式
    
71.         utilObj.InitializeUserInput 1, MstrKeyWordList
    
72.         vattmpPnt1 = utilObj.GetPoint(, "Start point (eXit) :")
    
73.         
    
74.         If Err Then
    
75.             Err.Clear
    
76.             If StrComp(Err.Description, "User input is a keyword", 1) = 0 Then
    
77.                 MstrInputString = utilObj.GetInput
    
78.                 If UCase(MstrInputString) = "X" Or MstrInputString = "" Then GoTo theEnd
    
79.             Else
    
80.                 GoTo theEnd
    
81.             End If
    
82.         End If
    
83.         
    
84.         Call ChangeOSNAP(False) '关闭捕捉模式
    
85.         utilObj.InitializeUserInput 1, MstrKeyWordList
    
86.         vattmpPnt2 = utilObj.GetPoint(vattmpPnt1, "To point (eXit) :")
    
87.         If Err Then
    
88.             Err.Clear
    
89.             If StrComp(Err.Description, "User input is a keyword", 1) = 0 Then
    
90.                 MstrInputString = utilObj.GetInput
    
91.                 If UCase(MstrInputString) = "X" Or MstrInputString = "" Then GoTo theEnd
    
92.             Else
    
93.                 GoTo theEnd
    
94.             End If
    
95.         End If
    
96.         
    
97.         blnRightDirection = (vattmpPnt2(0) >= vattmpPnt1(0)) '确定引线标注的标注方向
    
98.         strPntXYFormatted(1) = "Y=" & Format(Trim(Round((vattmpPnt1(0)), MlngCorBit)), strFormat)
    
99.         '标注坐标Y，MlngCorBit：全局变量，另外赋值，保留的小数位数
    
100.         strPntXYFormatted(0) = "X=" & Format(Trim(Round((vattmpPnt1(1)), MlngCorBit)), strFormat)
     
101.         '标注坐标X
     
102. 
     
103.         If Not blnFoundIt Then '图形文件中如果没有“BLK_LEADER”则生成该土块
     
104.             Set objBlock = acadDoc.Blocks.Add(dblOriginPnt, strConstLeaderBlock)
     
105.             dblStartPnt(0) = dblOriginPnt(0)
     
106.             dblStartPnt(1) = dblOriginPnt(1) + dblconTextRiseRatio * dbltmpTH
     
107.             Set objAtt = objBlock.AddAttribute(dbltmpTH, acAttributeModePreset, "1", dblStartPnt, _
     
108.             "1", strPntXYFormatted(0))
     
109.    
     
110.             dblStartPnt(1) = dblOriginPnt(1) + dblconTextFallRatio * dbltmpTH
     
111.             Set objAtt = objBlock.AddAttribute(dbltmpTH, acAttributeModePreset, "1", dblStartPnt, _
     
112.             "1", strPntXYFormatted(1))
     
113.             blnFoundIt = True
     
114.         End If
     
115.         
     
116.         dblStartPnt(0) = vattmpPnt1(0)
     
117.         dblStartPnt(1) = vattmpPnt1(1)
     
118.         Set objBlock = moSpace.InsertBlock(dblStartPnt, strConstLeaderBlock, 1, 1, 0) '插入图块
     
119.         
     
120.         vatAttVars = objBlock.GetAttributes
     
121.         dblStartPnt(0) = vattmpPnt2(0) + 0.1 * dbltmpTH
     
122.         dblStartPnt(1) = vattmpPnt2(1) + dblconTextRiseRatio * dbltmpTH
     
123.         vatAttVars(0).insertionPoint = dblStartPnt
     
124.         vatAttVars(0).TextString = strPntXYFormatted(0)
     
125.         vatAttVars(0).Height = dbltmpTH
     
126.         '调整Y坐标（属性文字）位置、文字内容、字高。VBA插入图块时属性文字位置、文字内容不会随块变化
     
127.         
     
128.         dblStartPnt(1) = vattmpPnt2(1) + dblconTextFallRatio * dbltmpTH
     
129.         vatAttVars(1).insertionPoint = dblStartPnt
     
130.         vatAttVars(1).TextString = strPntXYFormatted(1)
     
131.         vatAttVars(1).Height = dbltmpTH
     
132.         '调整X坐标（属性文字）位置、文字内容、字高。
     
133.         
     
134.         Call objBlock.GetBoundingBox(vatPntMin, vatPntMax)  '取包围属性文字矩形框的左下角及右上角坐标
     
135.         If Not blnRightDirection Then
     
136.             dblEndpnt(0) = dblStartPnt(0) - vatPntMax(0) + vatPntMin(0)
     
137.             dblEndpnt(1) = dblStartPnt(1)
     
138.             
     
139.             dblStartPnt(0) = vattmpPnt2(0) + vatPntMin(0) - vatPntMax(0)
     
140.             dblStartPnt(1) = vattmpPnt2(1) + dblconTextRiseRatio * dbltmpTH
     
141.             vatAttVars(0).insertionPoint = dblStartPnt
     
142.             
     
143.             dblStartPnt(1) = vattmpPnt2(1) + dblconTextFallRatio * dbltmpTH
     
144.             vatAttVars(1).insertionPoint = dblStartPnt
     
145.         End If
     
146.         
     
147.         dblLeaderPLineVertex(0) = vattmpPnt1(0)
     
148.         dblLeaderPLineVertex(1) = vattmpPnt1(1)
     
149.         dblLeaderPLineVertex(2) = vattmpPnt2(0)
     
150.         dblLeaderPLineVertex(3) = vattmpPnt2(1)
     
151.         dblLeaderPLineVertex(4) = IIf(blnRightDirection, vatPntMax(0), dblEndpnt(0) - 0.1 * dbltmpTH)
     
152.         dblLeaderPLineVertex(5) = vattmpPnt2(1)
     
153.         Set objPLine = moSpace.AddLightWeightPolyline(dblLeaderPLineVertex)
     
154.         Set objPntGroup = acadDoc.Groups.Add("*")
     
155.         Set objtmpArray(0) = objBlock
     
156.         Set objtmpArray(1) = objPLine
     
157.         objPntGroup.AppendItems objtmpArray
     
158.     Loop
     
159. theEnd:
     
160.     Me.Show
     
161. End Sub
     
162. 
     
163. Function ChangeOSNAP(mySwith As Boolean)
     
164.     Dim vattmpRetValue As Variant
     
165.     vattmpRetValue = acadDoc.GetVariable("OSMODE")
     
166.     If vattmpRetValue = 0 Then vattmpRetValue = 167
     
167.     If mySwith Then
     
168.         vattmpRetValue = IIf((vattmpRetValue <= 4095), vattmpRetValue, vattmpRetValue - 16384)
     
169.     Else
     
170.         vattmpRetValue = IIf((vattmpRetValue <= 4095), vattmpRetValue + 16384, vattmpRetValue)
     
171.     End If
     
172.     Call acadDoc.SetVariable("OSMODE", vattmpRetValue)
     
173. End Function '切换捕捉模式，如果没有设置，则设置捕捉端点、中点、圆心、交点、垂足

    public acadApp As Object<br />     public acadDoc As Object<br />     public utilObj As Object<br />     Public moSpace As Object<br />     <br /> Private Sub cmdLeader_Click()<br />     Dim vattmpPnt1 As Variant  '标注点<br />     Dim vattmpPnt2 As Variant  '起始点<br /> <br />     Dim strPntXYFormatted(0 To 1) As String '格式化以后的XY坐标，字符串<br />     Dim blnRightDirection As Boolean<br />     Dim dblLeaderPLineVertex(0 To 5) As Double '标注引线顶点坐标<br />     Dim dblOriginPnt(0 To 2) As Double '坐标原点<br />     Dim dblStartPnt(0 To 2) As Double<br />     Dim dblEndpnt(0 To 2) As Double<br />     <br />     Dim vatPntMin As Variant <br />     '包围盒左下角坐标，用于确定文字长度，否则引线长度与引线不匹配<br />     Dim vatPntMax As Variant<br />     Dim objBlock As Object<br />     Dim objPLine As Object<br />     Dim objAtt As Object<br />     <br />     Dim blnFoundIt As Boolean<br />     Dim vatAttVars As Variant<br /> <br />     Dim dbltmpTH As Double '标注文字高度<br />     <br />     Dim objPntGroup As Object '组对象<br />     Dim objtmpArray(0 To 1) As Object '加入到组的所有对象<br />     dim  strFormat as string  '坐标文本格式<br /> <br />     Const dblconTextRiseRatio As Double = 0.3! '引线上部坐标向上便宜数量<br />     Const dblconTextFallRatio As Double = -1.3!<br />     Const strConstLeaderBlock As String = "BLK_Leader"  '图块名称<br />     '可以不用图块，不过用图块有其优越的地方，特别是以后自己的软件需要对其读写的时候<br /> <br />     On Error Resume Next<br />     Set acadApp = GetObject(, "AutoCAD.Application.14")<br />     If Err Then<br />         Err.Clear<br />         Set acadApp = CreateObject("AutoCAD.Application.14")<br />     End If<br />     Set acadDoc = acadApp.ActiveDocument<br />     Set utilObj = acadDoc.Utility<br />     Set moSpace = acadDoc.ModelSpace<br /> <br />     strFormat="###0.00" '坐标格式化样式，可以把123表示为123.00<br />     Me.Hide<br />     <br />     dbltmpTH = MdblTextHeight * (MdblPlotRatio)   'MdblTextHeight是1：1时字高，全局变量，需要另外赋值，<br />     'MdblPlotRatio为图纸比例，全局变量，需要另外赋值，dbltmpTH为实际字高，也可以根据自己的要求设置<br />     dblOriginPnt(0) = 0#<br />     dblOriginPnt(1) = 0#<br />     dblOriginPnt(2) = 0#<br />     dblStartPnt(2) = 0#<br />     dblEndpnt(2) = 0#<br />     <br />     blnFoundIt = False<br />     For Each objBlock In acadDoc.Blocks<br />         If StrComp(UCase(objBlock.Name), UCase(strConstLeaderBlock), 1) = 0 Then<br />             blnFoundIt = True<br />             Exit For<br />         End If<br />     Next objBlock '查找有没有图块"BLK_LEADER"<br />     <br />     MstrKeyWordList = "X eXit"<br />     Do While 1<br />         Call ChangeOSNAP(True)  '打开捕捉模式<br />         utilObj.InitializeUserInput 1, MstrKeyWordList<br />         vattmpPnt1 = utilObj.GetPoint(, "Start point (eXit) :")<br />         <br />         If Err Then<br />             Err.Clear<br />             If StrComp(Err.Description, "User input is a keyword", 1) = 0 Then<br />                 MstrInputString = utilObj.GetInput<br />                 If UCase(MstrInputString) = "X" Or MstrInputString = "" Then GoTo theEnd<br />             Else<br />                 GoTo theEnd<br />             End If<br />         End If<br />         <br />         Call ChangeOSNAP(False) '关闭捕捉模式<br />         utilObj.InitializeUserInput 1, MstrKeyWordList<br />         vattmpPnt2 = utilObj.GetPoint(vattmpPnt1, "To point (eXit) :")<br />         If Err Then<br />             Err.Clear<br />             If StrComp(Err.Description, "User input is a keyword", 1) = 0 Then<br />                 MstrInputString = utilObj.GetInput<br />                 If UCase(MstrInputString) = "X" Or MstrInputString = "" Then GoTo theEnd<br />             Else<br />                 GoTo theEnd<br />             End If<br />         End If<br />         <br />         blnRightDirection = (vattmpPnt2(0) >= vattmpPnt1(0)) '确定引线标注的标注方向<br />         strPntXYFormatted(1) = "Y=" & Format(Trim(Round((vattmpPnt1(0)), MlngCorBit)), strFormat) <br />         '标注坐标Y，MlngCorBit：全局变量，另外赋值，保留的小数位数<br />         strPntXYFormatted(0) = "X=" & Format(Trim(Round((vattmpPnt1(1)), MlngCorBit)), strFormat) <br />         '标注坐标X<br /> <br />         If Not blnFoundIt Then '图形文件中如果没有“BLK_LEADER”则生成该土块<br />             Set objBlock = acadDoc.Blocks.Add(dblOriginPnt, strConstLeaderBlock)<br />             dblStartPnt(0) = dblOriginPnt(0)<br />             dblStartPnt(1) = dblOriginPnt(1) + dblconTextRiseRatio * dbltmpTH<br />             Set objAtt = objBlock.AddAttribute(dbltmpTH, acAttributeModePreset, "1", dblStartPnt, _<br />             "1", strPntXYFormatted(0))<br />     <br />             dblStartPnt(1) = dblOriginPnt(1) + dblconTextFallRatio * dbltmpTH<br />             Set objAtt = objBlock.AddAttribute(dbltmpTH, acAttributeModePreset, "1", dblStartPnt, _<br />             "1", strPntXYFormatted(1))<br />             blnFoundIt = True<br />         End If<br />         <br />         dblStartPnt(0) = vattmpPnt1(0)<br />         dblStartPnt(1) = vattmpPnt1(1)<br />         Set objBlock = moSpace.InsertBlock(dblStartPnt, strConstLeaderBlock, 1, 1, 0) '插入图块<br />         <br />         vatAttVars = objBlock.GetAttributes<br />         dblStartPnt(0) = vattmpPnt2(0) + 0.1 * dbltmpTH<br />         dblStartPnt(1) = vattmpPnt2(1) + dblconTextRiseRatio * dbltmpTH<br />         vatAttVars(0).insertionPoint = dblStartPnt<br />         vatAttVars(0).TextString = strPntXYFormatted(0)<br />         vatAttVars(0).Height = dbltmpTH<br />         '调整Y坐标（属性文字）位置、文字内容、字高。VBA插入图块时属性文字位置、文字内容不会随块变化<br />         <br />         dblStartPnt(1) = vattmpPnt2(1) + dblconTextFallRatio * dbltmpTH<br />         vatAttVars(1).insertionPoint = dblStartPnt<br />         vatAttVars(1).TextString = strPntXYFormatted(1)<br />         vatAttVars(1).Height = dbltmpTH<br />         '调整X坐标（属性文字）位置、文字内容、字高。<br />         <br />         Call objBlock.GetBoundingBox(vatPntMin, vatPntMax)  '取包围属性文字矩形框的左下角及右上角坐标<br />         If Not blnRightDirection Then<br />             dblEndpnt(0) = dblStartPnt(0) - vatPntMax(0) + vatPntMin(0)<br />             dblEndpnt(1) = dblStartPnt(1)<br />             <br />             dblStartPnt(0) = vattmpPnt2(0) + vatPntMin(0) - vatPntMax(0)<br />             dblStartPnt(1) = vattmpPnt2(1) + dblconTextRiseRatio * dbltmpTH<br />             vatAttVars(0).insertionPoint = dblStartPnt<br />             <br />             dblStartPnt(1) = vattmpPnt2(1) + dblconTextFallRatio * dbltmpTH<br />             vatAttVars(1).insertionPoint = dblStartPnt<br />         End If<br />         <br />         dblLeaderPLineVertex(0) = vattmpPnt1(0)<br />         dblLeaderPLineVertex(1) = vattmpPnt1(1)<br />         dblLeaderPLineVertex(2) = vattmpPnt2(0)<br />         dblLeaderPLineVertex(3) = vattmpPnt2(1)<br />         dblLeaderPLineVertex(4) = IIf(blnRightDirection, vatPntMax(0), dblEndpnt(0) - 0.1 * dbltmpTH)<br />         dblLeaderPLineVertex(5) = vattmpPnt2(1)<br />         Set objPLine = moSpace.AddLightWeightPolyline(dblLeaderPLineVertex)<br />         Set objPntGroup = acadDoc.Groups.Add("*")<br />         Set objtmpArray(0) = objBlock<br />         Set objtmpArray(1) = objPLine<br />         objPntGroup.AppendItems objtmpArray<br />     Loop<br /> theEnd:<br />     Me.Show<br /> End Sub<br /> <br /> Function ChangeOSNAP(mySwith As Boolean)<br />     Dim vattmpRetValue As Variant<br />     vattmpRetValue = acadDoc.GetVariable("OSMODE")<br />     If vattmpRetValue = 0 Then vattmpRetValue = 167<br />     If mySwith Then<br />         vattmpRetValue = IIf((vattmpRetValue <= 4095), vattmpRetValue, vattmpRetValue - 16384)<br />     Else<br />         vattmpRetValue = IIf((vattmpRetValue <= 4095), vattmpRetValue + 16384, vattmpRetValue)<br />     End If<br />     Call acadDoc.SetVariable("OSMODE", vattmpRetValue)<br /> End Function '切换捕捉模式，如果没有设置，则设置捕捉端点、中点、圆心、交点、垂足