明经CAD社区

 找回密码
 注册

QQ登录

只需一步,快速开始

搜索
楼主: zzyong00

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

    [复制链接]
 楼主| 发表于 2015-4-5 22:54 | 显示全部楼层
本帖最后由 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:调用代码:
  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


2:用到的函数或方法的代码:
  1. Public Sub SelectSinglePLine(returnObj As AcadLWPolyline, _
  2.     basePnt As Variant, _
  3.     blnESC As Boolean)

  4.     On Error Resume Next

  5.     ' The following example waits for a selection from the user
  6. RETRY:
  7.     ThisDrawing.Utility.GetEntity returnObj, basePnt, "请选择任意一条多线段:"

  8.     'Debug.Print Err.Number, Err.Description
  9.     If Err.Number = -2147352567 Then
  10.         blnESC = True
  11.         Exit Sub
  12.     End If

  13.     If Err <> 0 Then
  14.         Err.Clear
  15.         GoTo RETRY
  16.     Else
  17.         returnObj.Highlight True
  18.     End If

  19. End Sub

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.     Set ObjCurve.Entity = objPL
  21.     Dim tmpPt As Variant
  22.     tmpPt = ObjCurve.GetClosestPointTo(BasePoint)
  23.     If Abs(tmpPt(0) - BasePoint(0)) > EPS Or Abs(tmpPt(1) - BasePoint(1)) > EPS Then MsgBox "指定桩号基点不在桩号线上!", vbExclamation + vbOKOnly, App.Title: Exit Sub
  24.     Dim dblBaseDist As Double    '桩号基点距起点距离
  25.     dblBaseDist = ObjCurve.GetDistanceAtPoint(tmpPt)
  26.     Dim dblAngle As Double, LeaderEndPt As Variant, TextPt As Variant, TextPt1(2) As Double, dblD As Double
  27.     Dim objL As AcadLine, objText As AcadText, strZH As String, dblCurveLen As Double
  28.     dblCurveLen = ObjCurve.length
  29.     dblD = 0
  30.     Do While dblD < dblCurveLen
  31.         tmpPt = ObjCurve.GetPointAtDistance(dblD)
  32.         TextPt = ObjCurve.GetFirstDerivative(ObjCurve.GetParameterAtPoint(tmpPt))
  33.         TextPt1(0) = TextPt(0) + tmpPt(0)
  34.         TextPt1(1) = TextPt(1) + tmpPt(1)
  35.         TextPt1(2) = 0
  36.         dblAngle = objDoc.Utility.AngleFromXAxis(tmpPt, TextPt1)
  37.         LeaderEndPt = objDoc.Utility.PolarPoint(tmpPt, TextPosition * PI / 2 + dblAngle, LeaderLength)
  38.         TextPt = objDoc.Utility.PolarPoint(tmpPt, TextPosition * PI / 2 + dblAngle, LeaderLength * 1.1)
  39.         Set objL = objDoc.ModelSpace.AddLine(tmpPt, LeaderEndPt)
  40.         objL.Update
  41.         strZH = Format(ObjCurve.GetDistanceAtPoint(tmpPt) - dblBaseDist - IncreaseDirection * dblCurveLen, "0+000.000")

  42.         Set objText = objDoc.ModelSpace.AddText(strZH, TextPt, TextHeight)
  43.         objText.Rotation = TextPosition * PI / 2 + dblAngle
  44.         objText.Alignment = acAlignmentMiddleLeft
  45.         objText.TextAlignmentPoint = TextPt
  46.         objText.Update
  47.         dblD = dblD + ZHStep
  48.     Loop
  49.     If Abs(dblD - dblCurveLen) > EPS Then
  50.         tmpPt = ObjCurve.EndPoint
  51.         TextPt = ObjCurve.GetFirstDerivative(ObjCurve.GetParameterAtPoint(tmpPt))
  52.         TextPt1(0) = TextPt(0) + tmpPt(0)
  53.         TextPt1(1) = TextPt(1) + tmpPt(1)
  54.         TextPt1(2) = 0
  55.         dblAngle = objDoc.Utility.AngleFromXAxis(tmpPt, TextPt1)
  56.         LeaderEndPt = objDoc.Utility.PolarPoint(tmpPt, TextPosition * PI / 2 + dblAngle, LeaderLength)
  57.         TextPt = objDoc.Utility.PolarPoint(tmpPt, TextPosition * PI / 2 + dblAngle, LeaderLength * 1.1)

  58.         Set objL = objDoc.ModelSpace.AddLine(tmpPt, LeaderEndPt)
  59.         objL.Update

  60.         strZH = Format(ObjCurve.GetDistanceAtPoint(tmpPt) - dblBaseDist - IncreaseDirection * dblCurveLen, "0+000.000")

  61.         Set objText = objDoc.ModelSpace.AddText(strZH, TextPt, TextHeight)
  62.         objText.Rotation = TextPosition * PI / 2 + dblAngle
  63.         objText.Alignment = acAlignmentMiddleLeft
  64.         objText.TextAlignmentPoint = TextPt
  65.         objText.Update
  66.         dblD = dblD + ZHStep

  67.     End If
  68.     '释放变量
  69.     Set ObjCurve = Nothing
  70. End Sub

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










本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有账号?注册

x
发表于 2015-4-5 23:18 | 显示全部楼层
用VB直接调用ObjectArx的函数 或者用.Net做个Com组件应该是可行的
好像以前efan发过一个.Net的Com组件的
发表于 2015-4-10 18:33 | 显示全部楼层
请教楼主,用vb6写的代码如何设置快捷键:比如我希望使用AA 来调用 MOU1.SUB1,该如何设置?

点评

我觉得你的意思是这个:http://bbs.mjtd.com/thread-113028-1-1.html  发表于 2015-4-11 00:05
发表于 2015-4-10 19:37 | 显示全部楼层
还有,我怎样给图标按钮指定过程

点评

图标按钮是指什么 ?command控件?click事件呀  发表于 2015-4-11 00:06
发表于 2015-4-11 21:37 | 显示全部楼层
szj612 发表于 2015-4-10 19:37
还有,我怎样给图标按钮指定过程

我指的是AUTOCAD的自定义命令按钮
发表于 2015-4-11 21:40 | 显示全部楼层
还有,楼主是否愿意给我留个Q号,可能会有些事情请你代劳,呵呵,当然是付辛苦费的
发表于 2015-4-25 11:38 | 显示全部楼层
向楼主学习,谢谢分享。
发表于 2015-4-25 14:47 | 显示全部楼层
楼主您好,请问能不能介绍一下关于读取多段线坐标、圆曲线坐标的知道。

点评

你是说多线段的中的圆弧吗?前面的相关代码  发表于 2015-4-25 16:05
发表于 2015-5-13 09:04 | 显示全部楼层
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软件!”请问是怎么回事,代码应该是没有问题的。

点评

一般cad在“忙”的时候就无法连接,有时候的确是因为一些未知原因获取不到cad对象,这个一般来说,没什么好办法,除非你对系统ROT表相当明白  发表于 2015-5-13 12:32
发表于 2015-5-16 11:27 | 显示全部楼层
非常感谢楼主的回复!谢谢。
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|CAD论坛|CAD教程|CAD下载|联系我们|关于明经|明经通道 ( 粤ICP备05003914号 )  
©2000-2023 明经通道 版权所有 本站代码,在未取得本站及作者授权的情况下,不得用于商业用途

GMT+8, 2024-3-29 22:29 , Processed in 0.183592 second(s), 18 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

快速回复 返回顶部 返回列表