用VB6进行Autocad的二次开发(原创)

zzyong00

我发现用vb开发的几乎没有啊

zzyong00

2、坐标标注
坐标标注本身很简单，类似的工具满天飞，我这里也贴一个

1. Public Sub SeriesCoordinate()                                                   '连续标坐标
   
2.     Dim blnExitSeriesCoord As Boolean
   
3.     ' InitCommonVar
   
4.     '全局变量
   
5.     Coordinate_TextHeight = 3
   
6.     ratio = 1
   
7.     TextRowSpace = 0.6
   
8. 
   
9.     Do
   
10.         Coordinate blnExitSeriesCoord '本子过程源码需要回复才能看到
    
11.     Loop Until blnExitSeriesCoord
    
12. End Sub
    

Public Sub SeriesCoordinate()                                                   '连续标坐标<br />     Dim blnExitSeriesCoord As Boolean<br />     ' InitCommonVar<br />     '全局变量<br />     Coordinate_TextHeight = 3<br />     ratio = 1<br />     TextRowSpace = 0.6<br /> <br />     Do<br />         Coordinate blnExitSeriesCoord '本子过程源码需要回复才能看到<br />     Loop Until blnExitSeriesCoord<br /> End Sub<br />

1.     On Error GoTo err1
   
2.     '    Dim Coordinate_TextHeight As Double '文字高
   
3.     '    Dim Ratio As Double '全局比例
   
4.     '    Dim TextRowSpace As Double '文字行间距
   
5.     '    Coordinate_TextHeight = 3
   
6.     '    Ratio = 1
   
7.     '    TextRowSpace = 0.6
   
8.     Dim p1, p2                                                                  '标注点坐标，标注文字位置
   
9.     p1 = ThisDrawing.Utility.GetPoint(, "请点击要标注的点（按回车键退出）:")
   
10.     p2 = ThisDrawing.Utility.GetPoint(p1, "请点击标注位置（按回车键退出）:")
    
11.     Dim T1   As AcadText, T2 As AcadText
    
12.     Dim strT As String, intStrL1 As Integer, intStrL2 As Integer                'Y和X坐标文字的长度
    
13.     strT = "X " & Format$(p1(1), "0.000")
    
14.     intStrL1 = Len(strT)
    
15.     Dim pt1(2) As Double, pt2(2) As Double                                      '文字坐标
    
16.     If p2(0) > p1(0) Then                                                       '确定标注点与标注文字位置的左右关系，以确定文字插入点
    
17.         pt1(0) = p2(0)
    
18.         pt1(1) = p2(1) + TextRowSpace / 2 * Coordinate_TextHeight * ratio
    
19.     Else
    
20.         pt1(0) = p2(0) - intStrL1 * Coordinate_TextHeight * ratio * _
    
21.         ThisDrawing.ActiveTextStyle.Width ^ 2                                   '宽度比例(总是宽度比例的平方，因为当前文字样式设了宽度，而AcadText本身又有个ScaleFactor,而且等于width）
    
22.         pt1(1) = p2(1) + TextRowSpace / 2 * Coordinate_TextHeight * ratio
    
23.     End If
    
24.     Set T1 = ThisDrawing.ModelSpace.AddText(strT, pt1, Coordinate_TextHeight * ratio)
    
25.     T1.Visible = False
    
26.     strT = "Y " & Format$(p1(0), "0.000")
    
27.     intStrL2 = Len(strT)
    
28.     pt2(0) = pt1(0)
    
29.     pt2(1) = pt1(1) - T1.Height * (1 + TextRowSpace)                            'TextRowSpace代表文字间距是TextRowSpace倍的字高
    
30.     Set T2 = ThisDrawing.ModelSpace.AddText(strT, pt2, Coordinate_TextHeight * ratio)
    
31.     T2.Visible = False
    
32.     Dim Pend(2) As Double                                                       '标注结束点
    
33.     Pend(0) = p2(0)
    
34.     Dim TminP, TmaxP
    
35.     If intStrL1 > intStrL2 Then                                                 '取最长文字长度
    
36.         T1.GetBoundingBox TminP, TmaxP
    
37.     Else
    
38.         T2.GetBoundingBox TminP, TmaxP
    
39.     End If
    
40.     If p2(0) > p1(0) Then                                                       '确定标注点与标注文字位置的左右关系，以确定标注结束点位置
    
41.         Pend(0) = p2(0) + (TmaxP(0) - TminP(0))
    
42.         Pend(1) = p2(1)
    
43.     Else
    
44.         Pend(0) = p2(0) - (TmaxP(0) - TminP(0))
    
45.         Pend(1) = p2(1)
    
46.         pt1(0) = Pend(0)
    
47.         pt2(0) = Pend(0)
    
48.         T1.InsertionPoint = pt1
    
49.         T2.InsertionPoint = pt2
    
50.     End If
    
51.     T1.Visible = True
    
52.     T2.Visible = True
    
53. 
    
54.     Dim L1 As AcadLine, L2 As AcadLine
    
55.     Set L1 = ThisDrawing.ModelSpace.AddLine(p1, p2)
    
56.     Set L2 = ThisDrawing.ModelSpace.AddLine(p2, Pend)
    
57.     Exit Sub
    
58. err1:
    
59.     Err.Clear
    
60.     blnExitSeriesCoord = True
    
61. End Sub
    

    On Error GoTo err1<br />     '    Dim Coordinate_TextHeight As Double '文字高<br />     '    Dim Ratio As Double '全局比例<br />     '    Dim TextRowSpace As Double '文字行间距<br />     '    Coordinate_TextHeight = 3<br />     '    Ratio = 1<br />     '    TextRowSpace = 0.6<br />     Dim p1, p2                                                                  '标注点坐标，标注文字位置<br />     p1 = ThisDrawing.Utility.GetPoint(, "请点击要标注的点（按回车键退出）:")<br />     p2 = ThisDrawing.Utility.GetPoint(p1, "请点击标注位置（按回车键退出）:")<br />     Dim T1   As AcadText, T2 As AcadText<br />     Dim strT As String, intStrL1 As Integer, intStrL2 As Integer                'Y和X坐标文字的长度<br />     strT = "X " & Format$(p1(1), "0.000")<br />     intStrL1 = Len(strT)<br />     Dim pt1(2) As Double, pt2(2) As Double                                      '文字坐标<br />     If p2(0) > p1(0) Then                                                       '确定标注点与标注文字位置的左右关系，以确定文字插入点<br />         pt1(0) = p2(0)<br />         pt1(1) = p2(1) + TextRowSpace / 2 * Coordinate_TextHeight * ratio<br />     Else<br />         pt1(0) = p2(0) - intStrL1 * Coordinate_TextHeight * ratio * _<br />         ThisDrawing.ActiveTextStyle.Width ^ 2                                   '宽度比例(总是宽度比例的平方，因为当前文字样式设了宽度，而AcadText本身又有个ScaleFactor,而且等于width）<br />         pt1(1) = p2(1) + TextRowSpace / 2 * Coordinate_TextHeight * ratio<br />     End If<br />     Set T1 = ThisDrawing.ModelSpace.AddText(strT, pt1, Coordinate_TextHeight * ratio)<br />     T1.Visible = False<br />     strT = "Y " & Format$(p1(0), "0.000")<br />     intStrL2 = Len(strT)<br />     pt2(0) = pt1(0)<br />     pt2(1) = pt1(1) - T1.Height * (1 + TextRowSpace)                            'TextRowSpace代表文字间距是TextRowSpace倍的字高<br />     Set T2 = ThisDrawing.ModelSpace.AddText(strT, pt2, Coordinate_TextHeight * ratio)<br />     T2.Visible = False<br />     Dim Pend(2) As Double                                                       '标注结束点<br />     Pend(0) = p2(0)<br />     Dim TminP, TmaxP<br />     If intStrL1 > intStrL2 Then                                                 '取最长文字长度<br />         T1.GetBoundingBox TminP, TmaxP<br />     Else<br />         T2.GetBoundingBox TminP, TmaxP<br />     End If<br />     If p2(0) > p1(0) Then                                                       '确定标注点与标注文字位置的左右关系，以确定标注结束点位置<br />         Pend(0) = p2(0) + (TmaxP(0) - TminP(0))<br />         Pend(1) = p2(1)<br />     Else<br />         Pend(0) = p2(0) - (TmaxP(0) - TminP(0))<br />         Pend(1) = p2(1)<br />         pt1(0) = Pend(0)<br />         pt2(0) = Pend(0)<br />         T1.InsertionPoint = pt1<br />         T2.InsertionPoint = pt2<br />     End If<br />     T1.Visible = True<br />     T2.Visible = True<br /> <br />     Dim L1 As AcadLine, L2 As AcadLine<br />     Set L1 = ThisDrawing.ModelSpace.AddLine(p1, p2)<br />     Set L2 = ThisDrawing.ModelSpace.AddLine(p2, Pend)<br />     Exit Sub<br /> err1:<br />     Err.Clear<br />     blnExitSeriesCoord = True<br /> End Sub<br />

对于vb或vba来说，在没创建AcadText对象之前，很难精确算出AcadText对象的长度，本例子中，先大致估算，然后生成AcadText对象，但暂时隐藏它，通过GetBoundingBox 取得AcadText对象真实大小后，再调整AcadText对象位置和直线长度！

chenshulu

zzyong00 发表于 2014-10-25 22:30
我发现用vb开发的几乎没有啊

很多，不要怀疑，等的花儿都谢了，

xiayouxyj

楼主太强了。有空就来这里学习了。

jicqj

vb6是32位的 如何改写成更高版本的 .net支持64位呢

819534890

很强大，学习了

lsmgys

谢谢，正想学这方面的东西

yanyanjun999

我也来学习一下

憨哥哥唱情歌

我也来学习一下

我有点喜欢cad

好好学习vba