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

zzyong00

在本论坛的lisp版，有些高手放出了标注桩号的一些lisp代码，但在vba/vb版，却一个也没有，客观上讲，这是vba的一些弱项导致的，
在vba中，没有Curve类，也没有vlax-curve-get族函数，如下：vlax-curve-getPointAtDist
vlax-curve-getPointAtParam ;
vlax-curve-getDistAtPoint ;
vlax-curve-getDistAtParam ;
vlax-curve-getParamAtPoint ;;
vlax-curve-getParamAtDist ;;
vlax-curve-getStartParam ;;
vlax-curve-getendParam ;;
vlax-curve-getStartPoint ;;;
vlax-curve-getEndPoint;;
vlax-curve-getFirstDeriv;;
vlax-curve-getSecondDeriv;;
vlax-curve-getSecondDeriv

如果自己实现以上函数，达到Autodesk函数的水平，实在不容易（也不是不可能），幸好，我们有vb调用lisp的类VLAX.cls（BY Frank Oquendo）,而且，这位大神Frank Oquendo，还实现了Curve.cls类，让我们后来人轻松了很多！在此，我向前辈致敬！
不多说了，先看效果：

代码：
1:调用代码：

1. AppActivate objCad.Caption
   
2. Dim objPL As AcadLWPolyline, pt1 As Variant, blnESC As Boolean
   
3. SelectSinglePLine objPL, pt1, blnESC
   
4. If blnESC Then Exit Sub
   
5. Dim pt(2) As Double
   
6. pt1 = ThisDrawing.Utility.GetPoint(, "请指定桩号基点：")
   
7. pt(0) = pt1(0)
   
8. pt(1) = pt1(1)
   
9. MarkZhuangHao objPL, pt, 20, 0, -1, 3, 10
   
10. ThisDrawing.Regen acAllViewports
    

AppActivate objCad.Caption<br /> Dim objPL As AcadLWPolyline, pt1 As Variant, blnESC As Boolean<br /> SelectSinglePLine objPL, pt1, blnESC<br /> If blnESC Then Exit Sub<br /> Dim pt(2) As Double<br /> pt1 = ThisDrawing.Utility.GetPoint(, "请指定桩号基点：")<br /> pt(0) = pt1(0)<br /> pt(1) = pt1(1)<br /> MarkZhuangHao objPL, pt, 20, 0, -1, 3, 10<br /> ThisDrawing.Regen acAllViewports<br />

2：用到的函数或方法的代码：

1. Public Sub SelectSinglePLine(returnObj As AcadLWPolyline, _
   
2.     basePnt As Variant, _
   
3.     blnESC As Boolean)
   
4. 
   
5.     On Error Resume Next
   
6. 
   
7.     ' The following example waits for a selection from the user
   
8. RETRY:
   
9.     ThisDrawing.Utility.GetEntity returnObj, basePnt, "请选择任意一条多线段："
   
10. 
    
11.     'Debug.Print Err.Number, Err.Description
    
12.     If Err.Number = -2147352567 Then
    
13.         blnESC = True
    
14.         Exit Sub
    
15.     End If
    
16. 
    
17.     If Err <> 0 Then
    
18.         Err.Clear
    
19.         GoTo RETRY
    
20.     Else
    
21.         returnObj.Highlight True
    
22.     End If
    
23. 
    
24. End Sub
    

Public Sub SelectSinglePLine(returnObj As AcadLWPolyline, _<br />     basePnt As Variant, _<br />     blnESC As Boolean)<br /> <br />     On Error Resume Next<br /> <br />     ' The following example waits for a selection from the user<br /> RETRY:<br />     ThisDrawing.Utility.GetEntity returnObj, basePnt, "请选择任意一条多线段："<br /> <br />     'Debug.Print Err.Number, Err.Description<br />     If Err.Number = -2147352567 Then<br />         blnESC = True<br />         Exit Sub<br />     End If<br /> <br />     If Err <> 0 Then<br />         Err.Clear<br />         GoTo RETRY<br />     Else<br />         returnObj.Highlight True<br />     End If<br /> <br /> End Sub<br />

3.主要的过程：

1. '标注桩号
   
2. Public Sub MarkZhuangHao(objPL As AcadLWPolyline, _
   
3.                         BasePoint() As Double, _
   
4.                         Optional ZHStep As Double = 20, _
   
5.                         Optional IncreaseDirection As Long = 0, _
   
6.                         Optional TextPosition As Long = 1, _
   
7.                         Optional TextHeight As Double = 3, _
   
8.                         Optional LeaderLength As Double = 3)
   
9.     'objPL 桩号线
   
10.     'BasePoint 桩号起点
    
11.     'IncreaseDirection 桩号增加方向，与objPl点号增长方向一致为0，相反为1
    
12.     'TextPosition 桩号文字标注位置，1，在ojbPL上面，-1在objPl下面
    
13.     'TextHeight 文字高度
    
14.     'LeaderLength 引线长度
    
15.     Dim objDoc As AcadDocument
    
16.     Set objDoc = ThisDrawing
    
17.     '定义引用曲线类模块
    
18.     Dim ObjCurve As Curve
    
19.     Set ObjCurve = New Curve
    
20. 
    
21.     Set ObjCurve.Entity = objPL
    
22.     Dim tmpPt As Variant
    
23.     tmpPt = ObjCurve.GetClosestPointTo(BasePoint)
    
24.     If Abs(tmpPt(0) - BasePoint(0)) > EPS Or Abs(tmpPt(1) - BasePoint(1)) > EPS Then MsgBox "指定桩号基点不在桩号线上！", vbExclamation + vbOKOnly, App.Title: Exit Sub
    
25.     Dim dblBaseDist As Double    '桩号基点距起点距离
    
26.     dblBaseDist = ObjCurve.GetDistanceAtPoint(tmpPt)
    
27.     Dim dblAngle As Double, LeaderEndPt As Variant, TextPt As Variant, TextPt1(2) As Double, dblD As Double
    
28.     Dim objL As AcadLine, objText As AcadText, strZH As String, dblCurveLen As Double
    
29.     dblCurveLen = ObjCurve.length
    
30.     dblD = 0
    
31.     Do While dblD < dblCurveLen
    
32.         tmpPt = ObjCurve.GetPointAtDistance(dblD)
    
33.         TextPt = ObjCurve.GetFirstDerivative(ObjCurve.GetParameterAtPoint(tmpPt))
    
34.         TextPt1(0) = TextPt(0) + tmpPt(0)
    
35.         TextPt1(1) = TextPt(1) + tmpPt(1)
    
36.         TextPt1(2) = 0
    
37.         dblAngle = objDoc.Utility.AngleFromXAxis(tmpPt, TextPt1)
    
38.         LeaderEndPt = objDoc.Utility.PolarPoint(tmpPt, TextPosition * PI / 2 + dblAngle, LeaderLength)
    
39.         TextPt = objDoc.Utility.PolarPoint(tmpPt, TextPosition * PI / 2 + dblAngle, LeaderLength * 1.1)
    
40.         Set objL = objDoc.ModelSpace.AddLine(tmpPt, LeaderEndPt)
    
41.         objL.Update
    
42.         strZH = Format(ObjCurve.GetDistanceAtPoint(tmpPt) - dblBaseDist - IncreaseDirection * dblCurveLen, "0+000.000")
    
43. 
    
44.         Set objText = objDoc.ModelSpace.AddText(strZH, TextPt, TextHeight)
    
45.         objText.Rotation = TextPosition * PI / 2 + dblAngle
    
46.         objText.Alignment = acAlignmentMiddleLeft
    
47.         objText.TextAlignmentPoint = TextPt
    
48.         objText.Update
    
49.         dblD = dblD + ZHStep
    
50.     Loop
    
51.     If Abs(dblD - dblCurveLen) > EPS Then
    
52.         tmpPt = ObjCurve.EndPoint
    
53.         TextPt = ObjCurve.GetFirstDerivative(ObjCurve.GetParameterAtPoint(tmpPt))
    
54.         TextPt1(0) = TextPt(0) + tmpPt(0)
    
55.         TextPt1(1) = TextPt(1) + tmpPt(1)
    
56.         TextPt1(2) = 0
    
57.         dblAngle = objDoc.Utility.AngleFromXAxis(tmpPt, TextPt1)
    
58.         LeaderEndPt = objDoc.Utility.PolarPoint(tmpPt, TextPosition * PI / 2 + dblAngle, LeaderLength)
    
59.         TextPt = objDoc.Utility.PolarPoint(tmpPt, TextPosition * PI / 2 + dblAngle, LeaderLength * 1.1)
    
60. 
    
61.         Set objL = objDoc.ModelSpace.AddLine(tmpPt, LeaderEndPt)
    
62.         objL.Update
    
63. 
    
64.         strZH = Format(ObjCurve.GetDistanceAtPoint(tmpPt) - dblBaseDist - IncreaseDirection * dblCurveLen, "0+000.000")
    
65. 
    
66.         Set objText = objDoc.ModelSpace.AddText(strZH, TextPt, TextHeight)
    
67.         objText.Rotation = TextPosition * PI / 2 + dblAngle
    
68.         objText.Alignment = acAlignmentMiddleLeft
    
69.         objText.TextAlignmentPoint = TextPt
    
70.         objText.Update
    
71.         dblD = dblD + ZHStep
    
72. 
    
73.     End If
    
74.     '释放变量
    
75.     Set ObjCurve = Nothing
    
76. End Sub
    

'标注桩号<br /> Public Sub MarkZhuangHao(objPL As AcadLWPolyline, _<br />                         BasePoint() As Double, _<br />                         Optional ZHStep As Double = 20, _<br />                         Optional IncreaseDirection As Long = 0, _<br />                         Optional TextPosition As Long = 1, _<br />                         Optional TextHeight As Double = 3, _<br />                         Optional LeaderLength As Double = 3)<br />     'objPL 桩号线<br />     'BasePoint 桩号起点<br />     'IncreaseDirection 桩号增加方向，与objPl点号增长方向一致为0，相反为1<br />     'TextPosition 桩号文字标注位置，1，在ojbPL上面，-1在objPl下面<br />     'TextHeight 文字高度<br />     'LeaderLength 引线长度<br />     Dim objDoc As AcadDocument<br />     Set objDoc = ThisDrawing<br />     '定义引用曲线类模块<br />     Dim ObjCurve As Curve<br />     Set ObjCurve = New Curve<br /> <br />     Set ObjCurve.Entity = objPL<br />     Dim tmpPt As Variant<br />     tmpPt = ObjCurve.GetClosestPointTo(BasePoint)<br />     If Abs(tmpPt(0) - BasePoint(0)) > EPS Or Abs(tmpPt(1) - BasePoint(1)) > EPS Then MsgBox "指定桩号基点不在桩号线上！", vbExclamation + vbOKOnly, App.Title: Exit Sub<br />     Dim dblBaseDist As Double    '桩号基点距起点距离<br />     dblBaseDist = ObjCurve.GetDistanceAtPoint(tmpPt)<br />     Dim dblAngle As Double, LeaderEndPt As Variant, TextPt As Variant, TextPt1(2) As Double, dblD As Double<br />     Dim objL As AcadLine, objText As AcadText, strZH As String, dblCurveLen As Double<br />     dblCurveLen = ObjCurve.length<br />     dblD = 0<br />     Do While dblD < dblCurveLen<br />         tmpPt = ObjCurve.GetPointAtDistance(dblD)<br />         TextPt = ObjCurve.GetFirstDerivative(ObjCurve.GetParameterAtPoint(tmpPt))<br />         TextPt1(0) = TextPt(0) + tmpPt(0)<br />         TextPt1(1) = TextPt(1) + tmpPt(1)<br />         TextPt1(2) = 0<br />         dblAngle = objDoc.Utility.AngleFromXAxis(tmpPt, TextPt1)<br />         LeaderEndPt = objDoc.Utility.PolarPoint(tmpPt, TextPosition * PI / 2 + dblAngle, LeaderLength)<br />         TextPt = objDoc.Utility.PolarPoint(tmpPt, TextPosition * PI / 2 + dblAngle, LeaderLength * 1.1)<br />         Set objL = objDoc.ModelSpace.AddLine(tmpPt, LeaderEndPt)<br />         objL.Update<br />         strZH = Format(ObjCurve.GetDistanceAtPoint(tmpPt) - dblBaseDist - IncreaseDirection * dblCurveLen, "0+000.000")<br /> <br />         Set objText = objDoc.ModelSpace.AddText(strZH, TextPt, TextHeight)<br />         objText.Rotation = TextPosition * PI / 2 + dblAngle<br />         objText.Alignment = acAlignmentMiddleLeft<br />         objText.TextAlignmentPoint = TextPt<br />         objText.Update<br />         dblD = dblD + ZHStep<br />     Loop<br />     If Abs(dblD - dblCurveLen) > EPS Then<br />         tmpPt = ObjCurve.EndPoint<br />         TextPt = ObjCurve.GetFirstDerivative(ObjCurve.GetParameterAtPoint(tmpPt))<br />         TextPt1(0) = TextPt(0) + tmpPt(0)<br />         TextPt1(1) = TextPt(1) + tmpPt(1)<br />         TextPt1(2) = 0<br />         dblAngle = objDoc.Utility.AngleFromXAxis(tmpPt, TextPt1)<br />         LeaderEndPt = objDoc.Utility.PolarPoint(tmpPt, TextPosition * PI / 2 + dblAngle, LeaderLength)<br />         TextPt = objDoc.Utility.PolarPoint(tmpPt, TextPosition * PI / 2 + dblAngle, LeaderLength * 1.1)<br /> <br />         Set objL = objDoc.ModelSpace.AddLine(tmpPt, LeaderEndPt)<br />         objL.Update<br /> <br />         strZH = Format(ObjCurve.GetDistanceAtPoint(tmpPt) - dblBaseDist - IncreaseDirection * dblCurveLen, "0+000.000")<br /> <br />         Set objText = objDoc.ModelSpace.AddText(strZH, TextPt, TextHeight)<br />         objText.Rotation = TextPosition * PI / 2 + dblAngle<br />         objText.Alignment = acAlignmentMiddleLeft<br />         objText.TextAlignmentPoint = TextPt<br />         objText.Update<br />         dblD = dblD + ZHStep<br /> <br />     End If<br />     '释放变量<br />     Set ObjCurve = Nothing<br /> End Sub<br />

其它没有的函数或过程，请看本贴！
当然，最重要的还是这两个类！
在调试过程中，发现vlax类经常报错，看来，频繁调用vlax来执行lisp还是有些问题的！我猜测是vba调用VL类型库不稳定，有可能是VL类库后台的问题，也就是这个问题归结为Autodesk公司的问题，为什么这么说，因为从autocad2004以后,vl类库就再也没更新过！它可能是autodesk所放弃的东西，难免有问题！

雪山飞狐_lzh

用VB直接调用ObjectArx的函数 或者用.Net做个Com组件应该是可行的
好像以前efan发过一个.Net的Com组件的

szj612

请教楼主，用vb6写的代码如何设置快捷键：比如我希望使用AA 来调用 MOU1.SUB1,该如何设置？

szj612

还有，我怎样给图标按钮指定过程

szj612

szj612 发表于 2015-4-10 19:37
还有，我怎样给图标按钮指定过程

我指的是AUTOCAD的自定义命令按钮

szj612

还有，楼主是否愿意给我留个Q号，可能会有些事情请你代劳，呵呵，当然是付辛苦费的

歪文子

向楼主学习，谢谢分享。

歪文子

楼主您好，请问能不能介绍一下关于读取多段线坐标、圆曲线坐标的知道。

歪文子

Dim acadApp As AcadApplication '定义一个AutoCAD.Application
Dim acadDoc As AcadDocument '定义一个CAD文档
On Error Resume Next
Set acadApp = GetObject(, "AutoCAD.Application")
If Err <> 0 Then
MsgBox "请先打开CAD软件！", 64, "提示信息": Exit Sub
End If
Set acadDoc = acadApp.ActiveDocument
acadApp.WindowState = acMax
楼主您好，请问我用以上代码连接CAD，但是有些电脑可以读取到内存中运行的CAD，有些读不到内存中运行的CAD，本来电脑中已经打开了CAD，但是还是提示“请先打开CAD软件！”请问是怎么回事，代码应该是没有问题的。

歪文子

非常感谢楼主的回复！谢谢。