[原创]用纯粹的几何计算的方法实现了Autocad的Curve类

zzyong00

用vba或vb进行Auotcad二次开发的人都知道，AutoCAD的VBA接口没有提供Vlisp中的vlax-curve-get族函数。如下：


没有这些函数，有时候开发时，总感觉缩手缩脚，而且，这些函数实现起来也不太容易，本人前一阵子用vlax类调用vlisp的这些函数，但是，太不稳定，经常无故出错，因此，决心自已写一个这样的组件！经过努力，终于有点结果了！
本COM组件的主要功能是用纯粹的几何计算的方法实现了Autocad的Curve类，目前支持曲线为：LWPOLYLINE,LINE,ARC,CIRCLE。本COM组件主要有三个文件组成：Curve17.dll,Curve18.dll,geometry.dll。其中Curve17.dll,Curve18.dll为activex dll，可以在任何文件夹中，只需要运行“注册.bat”注册一下即可，而geometry.dll为标准的dll，需要复制到c:\windows\system32(windowxp系统) 或C:\Windows\SysWOW64(window7系统) 中。

Curve17.dll对应于Autocad2007~Autocad2009，即R17;同理，Curve18.dll,对应于R18。
在这里做一个简单的演示：演示曲线上离指定点最近的点



演示代码(Project.dvb全部代码)：

1. Public Sub 点到曲线最近距离()
   
2. 
   
3.     Dim objSset As AcadSelectionSet
   
4. 
   
5.     SelectLots "MEA~PL~TMP~123", "LWPOLYLINE,LINE,ARC,CIRCLE"
   
6.     Set objSset = ThisDrawing.SelectionSets("MEA~PL~TMP~123")
   
7.     If objSset.Count = 0 Then Exit Sub
   
8.     '定义引用曲线类模块
   
9. 
   
10.     Dim ObjCurve As Object
    
11.     Set ObjCurve = CreateObject("Curve_zzyong00.Curve")
    
12. 
    
13.     Dim pt(2) As Double, pt1 As Variant, i As Long
    
14.     pt1 = ThisDrawing.Utility.GetPoint(, "请指定点：")
    
15.     pt(0) = pt1(0)
    
16.     pt(1) = pt1(1)
    
17.     For i = 0 To objSset.Count - 1
    
18.         Set ObjCurve.Entity = objSset.Item(i)
    
19.         Dim tmpPt As Variant
    
20.         tmpPt = ObjCurve.GetClosestPointTo(pt, False)
    
21.         ThisDrawing.ModelSpace.AddLine pt1, tmpPt
    
22.     Next i
    
23. End Sub
    
24. Public Sub SelectLots(ByVal Ssetname As String, ByVal objName As String)
    
25.     Dim sSetObj As AcadSelectionSet, flag As Boolean
    
26.     For Each sSetObj In ThisDrawing.SelectionSets
    
27.         If sSetObj.Name = Ssetname Then
    
28.             flag = True
    
29.             Exit For
    
30.         End If
    
31.     Next
    
32.     If flag Then sSetObj.Delete                                                 '创建集合，如集存在，则删除，新建
    
33.     Set sSetObj = ThisDrawing.SelectionSets.Add(Ssetname)
    
34.     ThisDrawing.Utility.Prompt "请选择对象，可以框选" & vbCrLf
    
35. 
    
36.     If objName <> "" Then
    
37.         Dim gpCode(0)    As Integer
    
38.         Dim dataValue(0) As Variant
    
39.         gpCode(0) = 0
    
40.         dataValue(0) = objName
    
41.         Dim groupCode As Variant, dataCode As Variant
    
42.         groupCode = gpCode
    
43.         dataCode = dataValue
    
44.         sSetObj.SelectOnScreen groupCode, dataCode
    
45.     ElseIf objName = "" Then
    
46.         sSetObj.SelectOnScreen
    
47.     End If
    
48. End Sub
    

Public Sub 点到曲线最近距离()<br /> <br />     Dim objSset As AcadSelectionSet<br /> <br />     SelectLots "MEA~PL~TMP~123", "LWPOLYLINE,LINE,ARC,CIRCLE"<br />     Set objSset = ThisDrawing.SelectionSets("MEA~PL~TMP~123")<br />     If objSset.Count = 0 Then Exit Sub<br />     '定义引用曲线类模块<br /> <br />     Dim ObjCurve As Object<br />     Set ObjCurve = CreateObject("Curve_zzyong00.Curve")<br /> <br />     Dim pt(2) As Double, pt1 As Variant, i As Long<br />     pt1 = ThisDrawing.Utility.GetPoint(, "请指定点：")<br />     pt(0) = pt1(0)<br />     pt(1) = pt1(1)<br />     For i = 0 To objSset.Count - 1<br />         Set ObjCurve.Entity = objSset.Item(i)<br />         Dim tmpPt As Variant<br />         tmpPt = ObjCurve.GetClosestPointTo(pt, False)<br />         ThisDrawing.ModelSpace.AddLine pt1, tmpPt<br />     Next i<br /> End Sub<br /> Public Sub SelectLots(ByVal Ssetname As String, ByVal objName As String)<br />     Dim sSetObj As AcadSelectionSet, flag As Boolean<br />     For Each sSetObj In ThisDrawing.SelectionSets<br />         If sSetObj.Name = Ssetname Then<br />             flag = True<br />             Exit For<br />         End If<br />     Next<br />     If flag Then sSetObj.Delete                                                 '创建集合，如集存在，则删除，新建<br />     Set sSetObj = ThisDrawing.SelectionSets.Add(Ssetname)<br />     ThisDrawing.Utility.Prompt "请选择对象，可以框选" & vbCrLf<br /> <br />     If objName <> "" Then<br />         Dim gpCode(0)    As Integer<br />         Dim dataValue(0) As Variant<br />         gpCode(0) = 0<br />         dataValue(0) = objName<br />         Dim groupCode As Variant, dataCode As Variant<br />         groupCode = gpCode<br />         dataCode = dataValue<br />         sSetObj.SelectOnScreen groupCode, dataCode<br />     ElseIf objName = "" Then<br />         sSetObj.SelectOnScreen<br />     End If<br /> End Sub<br />

更多演示请参照这个标桩号的例子：http://bbs.mjtd.com/forum.php?mo ... 2535&fromuid=332660

zzyong00

787116960 发表于 2023-11-15 21:56
大佬  在excelvba中运行不了 报错:运行时错误 '-2147221164 (80040154)':没有注册类

本COM组件主要有三个文件组成：Curve17.dll,Curve18.dll,geometry.dll。其中Curve17.dll,Curve18.dll为activex dll，可以在任何文件夹中，只需要运行“注册.bat”注册一下即可，而geometry.dll为标准的dll，需要复制到c:\windows\system32(windowxp系统) 或C:\Windows\SysWOW64(window7系统) 中。

zzyong00

新鲜8 发表于 2017-10-20 12:14
问版主一个问题怎么用vba代码关闭CAD（不保存关闭）

1. Public Sub ss()
   
2. Dim objDoc As AcadDocument, objcad As AcadApplication
   
3. Set objcad = ThisDrawing.Application
   
4. For Each objDoc In objcad.Documents
   
5.     objDoc.Close False
   
6. Next
   
7. objcad.Quit
   
8. 
   
9. End Sub

Public Sub ss()<br /> Dim objDoc As AcadDocument, objcad As AcadApplication<br /> Set objcad = ThisDrawing.Application<br /> For Each objDoc In objcad.Documents<br />     objDoc.Close False<br /> Next<br /> objcad.Quit<br /> <br /> End Sub

787116960

zzyong00 发表于 2024-1-6 10:42
本COM组件主要有三个文件组成：Curve17.dll,Curve18.dll,geometry.dll。其中Curve17.dll,Curve18.dll为ac ...

我想用excel中的vba来调用  但是一直出现错误  大佬能给个实例嘛

雪山飞狐_lzh

我记得cad的ge曲线库应该是可以脱离cad环境直接在.net调用。这样看用vb.net结合com也许是更好的方法

zzyong00

如果acge*.dll能够脱离cad环境直接被调用，哪可好了
我看了下acge18.dll，调用约定应该是cdecl方式,vb6正常情况下是不支持的

tester005

楼主是vba板块新兴的中坚力量啊

mycad

顶一下！！！！！！！！！！！

xinght99

楼主为后起之星呀

你好小崧

这个附件内容不支持CAD2006或者CAD2010吧？

zzyong00

你好小崧 发表于 2015-12-2 20:35
这个附件内容不支持CAD2006或者CAD2010吧？

Curve17.dll对应于Autocad2007~Autocad2009，即R17;同理，Curve18.dll,对应于R18,autocad2010-2012

zzyong00

如需要其它版本，可以联系我

你好小崧

zzyong00 发表于 2015-12-2 20:53
Curve17.dll对应于Autocad2007~Autocad2009，即R17;同理，Curve18.dll,对应于R18,autocad2010-2012

公司只是部分人用2010以上的版本，大多还是用的2006