本帖最后由 zzyong00 于 2015-4-5 23:06 编辑
在本论坛的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:调用代码：
AppActivate objCad.Caption
Dim objPL As AcadLWPolyline, pt1 As Variant, blnESC As Boolean
SelectSinglePLine objPL, pt1, blnESC
If blnESC Then Exit Sub
Dim pt(2) As Double
pt1 = ThisDrawing.Utility.GetPoint(, "请指定桩号基点：")
pt(0) = pt1(0)
pt(1) = pt1(1)
MarkZhuangHao objPL, pt, 20, 0, -1, 3, 10
ThisDrawing.Regen acAllViewports
2：用到的函数或方法的代码：
Public Sub SelectSinglePLine(returnObj As AcadLWPolyline, _
basePnt As Variant, _
blnESC As Boolean)
On Error Resume Next
' The following example waits for a selection from the user
RETRY:
ThisDrawing.Utility.GetEntity returnObj, basePnt, "请选择任意一条多线段："
'Debug.Print Err.Number, Err.Description
If Err.Number = -2147352567 Then
blnESC = True
Exit Sub
End If
If Err <> 0 Then
Err.Clear
GoTo RETRY
Else
returnObj.Highlight True
End If
End Sub
3.主要的过程：
'标注桩号
Public Sub MarkZhuangHao(objPL As AcadLWPolyline, _
BasePoint() As Double, _
Optional ZHStep As Double = 20, _
Optional IncreaseDirection As Long = 0, _
Optional TextPosition As Long = 1, _
Optional TextHeight As Double = 3, _
Optional LeaderLength As Double = 3)
'objPL 桩号线
'BasePoint 桩号起点
'IncreaseDirection 桩号增加方向，与objPl点号增长方向一致为0，相反为1
'TextPosition 桩号文字标注位置，1，在ojbPL上面，-1在objPl下面
'TextHeight 文字高度
'LeaderLength 引线长度
Dim objDoc As AcadDocument
Set objDoc = ThisDrawing
'定义引用曲线类模块
Dim ObjCurve As Curve
Set ObjCurve = New Curve
Set ObjCurve.Entity = objPL
Dim tmpPt As Variant
tmpPt = ObjCurve.GetClosestPointTo(BasePoint)
If Abs(tmpPt(0) - BasePoint(0)) > EPS Or Abs(tmpPt(1) - BasePoint(1)) > EPS Then MsgBox "指定桩号基点不在桩号线上！", vbExclamation + vbOKOnly, App.Title: Exit Sub
Dim dblBaseDist As Double '桩号基点距起点距离
dblBaseDist = ObjCurve.GetDistanceAtPoint(tmpPt)
Dim dblAngle As Double, LeaderEndPt As Variant, TextPt As Variant, TextPt1(2) As Double, dblD As Double
Dim objL As AcadLine, objText As AcadText, strZH As String, dblCurveLen As Double
dblCurveLen = ObjCurve.length
dblD = 0
Do While dblD < dblCurveLen
tmpPt = ObjCurve.GetPointAtDistance(dblD)
TextPt = ObjCurve.GetFirstDerivative(ObjCurve.GetParameterAtPoint(tmpPt))
TextPt1(0) = TextPt(0) + tmpPt(0)
TextPt1(1) = TextPt(1) + tmpPt(1)
TextPt1(2) = 0
dblAngle = objDoc.Utility.AngleFromXAxis(tmpPt, TextPt1)
LeaderEndPt = objDoc.Utility.PolarPoint(tmpPt, TextPosition * PI / 2 + dblAngle, LeaderLength)
TextPt = objDoc.Utility.PolarPoint(tmpPt, TextPosition * PI / 2 + dblAngle, LeaderLength * 1.1)
Set objL = objDoc.ModelSpace.AddLine(tmpPt, LeaderEndPt)
objL.Update
strZH = Format(ObjCurve.GetDistanceAtPoint(tmpPt) - dblBaseDist - IncreaseDirection * dblCurveLen, "0+000.000")
Set objText = objDoc.ModelSpace.AddText(strZH, TextPt, TextHeight)
objText.Rotation = TextPosition * PI / 2 + dblAngle
objText.Alignment = acAlignmentMiddleLeft
objText.TextAlignmentPoint = TextPt
objText.Update
dblD = dblD + ZHStep
Loop
If Abs(dblD - dblCurveLen) > EPS Then
tmpPt = ObjCurve.EndPoint
TextPt = ObjCurve.GetFirstDerivative(ObjCurve.GetParameterAtPoint(tmpPt))
TextPt1(0) = TextPt(0) + tmpPt(0)
TextPt1(1) = TextPt(1) + tmpPt(1)
TextPt1(2) = 0
dblAngle = objDoc.Utility.AngleFromXAxis(tmpPt, TextPt1)
LeaderEndPt = objDoc.Utility.PolarPoint(tmpPt, TextPosition * PI / 2 + dblAngle, LeaderLength)
TextPt = objDoc.Utility.PolarPoint(tmpPt, TextPosition * PI / 2 + dblAngle, LeaderLength * 1.1)
Set objL = objDoc.ModelSpace.AddLine(tmpPt, LeaderEndPt)
objL.Update
strZH = Format(ObjCurve.GetDistanceAtPoint(tmpPt) - dblBaseDist - IncreaseDirection * dblCurveLen, "0+000.000")
Set objText = objDoc.ModelSpace.AddText(strZH, TextPt, TextHeight)
objText.Rotation = TextPosition * PI / 2 + dblAngle
objText.Alignment = acAlignmentMiddleLeft
objText.TextAlignmentPoint = TextPt
objText.Update
dblD = dblD + ZHStep
End If
'释放变量
Set ObjCurve = Nothing
End Sub
其它没有的函数或过程，请看本贴！
当然，最重要的还是这两个类！
在调试过程中，发现vlax类经常报错，看来，频繁调用vlax来执行lisp还是有些问题的！我猜测是vba调用VL类型库不稳定，有可能是VL类库后台的问题，也就是这个问题归结为Autodesk公司的问题，为什么这么说，因为从autocad2004以后,vl类库就再也没更新过！它可能是autodesk所放弃的东西，难免有问题！
用VB直接调用ObjectArx的函数 或者用.Net做个Com组件应该是可行的
好像以前efan发过一个.Net的Com组件的
请教楼主，用vb6写的代码如何设置快捷键：比如我希望使用AA 来调用 MOU1.SUB1,该如何设置？
还有，我怎样给图标按钮指定过程
szj612 发表于 2015-4-10 19:37 static/image/common/back.gif
还有，我怎样给图标按钮指定过程
我指的是AUTOCAD的自定义命令按钮
还有，楼主是否愿意给我留个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软件！”请问是怎么回事，代码应该是没有问题的。
非常感谢楼主的回复！谢谢。