ARX的COM函数库之实体篇(acdbEntMake)

efan2000

通过封装ARX的函数，使之能够在VB、VBA或者.NET等中以COM方式访问。
acdbEntMake对应的COM函数为：Function AcdbEntMake(codetype, codevalue) As Long，其中codetype为整型的数组，codevalue为变体的数组，根据组码来确定类型。

1. ' 创建圆弧
   
2. Sub testAcdbEntMakeArc()
   
3.     Dim ct(0 To 4) As Integer
   
4.     Dim cv(0 To 4) As Variant
   
5.     ct(0) = 0
   
6.     cv(0) = "ARC"
   
7.     Dim pt1(0 To 2) As Double
   
8.     ct(1) = 10 ' 圆心
   
9.     cv(1) = pt1
   
10.     ct(2) = 40 ' 半径
    
11.     cv(2) = 1
    
12.     ct(3) = 50 ' 起点角度
    
13.     cv(3) = 0
    
14.     ct(4) = 51 ' 端点角度
    
15.     cv(4) = 45
    
16.   Debug.Print AcdbEntMake(ct, cv)
    
17. End Sub
    
18. 
    
19. ' 创建圆弧-新版
    
20. Sub testAcdbEntMakeArc()
    
21.     Dim ent As ResultBuffer
    
22.     Set ent = New ResultBuffer
    
23.     ent.AddTypedValue 0, "ARC"
    
24.     Dim pt(0 To 2) As Double
    
25.     ent.AddTypedValue 10, pt ' 圆心
    
26.     ent.AddTypedValue 40, 1 ' 半径
    
27.     ent.AddTypedValue 50, 0 ' 起点角度
    
28.     ent.AddTypedValue 51, 45 ' 端点角度
    
29.     Debug.Print AcdbEntMake(ent)
    
30. End Sub

' 创建圆弧<br /> Sub testAcdbEntMakeArc()<br />     Dim ct(0 To 4) As Integer<br />     Dim cv(0 To 4) As Variant<br />     ct(0) = 0<br />     cv(0) = "ARC"<br />     Dim pt1(0 To 2) As Double<br />     ct(1) = 10 ' 圆心<br />     cv(1) = pt1<br />     ct(2) = 40 ' 半径<br />     cv(2) = 1<br />     ct(3) = 50 ' 起点角度<br />     cv(3) = 0<br />     ct(4) = 51 ' 端点角度<br />     cv(4) = 45<br />   Debug.Print AcdbEntMake(ct, cv)<br /> End Sub<br /> <br /> ' 创建圆弧-新版<br /> Sub testAcdbEntMakeArc()<br />     Dim ent As ResultBuffer<br />     Set ent = New ResultBuffer<br />     ent.AddTypedValue 0, "ARC"<br />     Dim pt(0 To 2) As Double<br />     ent.AddTypedValue 10, pt ' 圆心<br />     ent.AddTypedValue 40, 1 ' 半径<br />     ent.AddTypedValue 50, 0 ' 起点角度<br />     ent.AddTypedValue 51, 45 ' 端点角度<br />     Debug.Print AcdbEntMake(ent)<br /> End Sub

1. ' 创建圆
   
2. Sub testAcdbEntMakeCircle()
   
3.     Dim ct(0 To 2) As Integer
   
4.     Dim cv(0 To 2) As Variant
   
5.     ct(0) = 0
   
6.     cv(0) = "CIRCLE"
   
7.     Dim pt1(0 To 2) As Double
   
8.     ct(1) = 10 ' 圆心
   
9.     cv(1) = pt1
   
10.     ct(2) = 40 ' 半径
    
11.     cv(2) = 3.5
    
12.     Debug.Print AcdbEntMake(ct, cv)
    
13. End Sub
    
14. 
    
15. ' 创建圆-新版
    
16. Sub testAcdbEntMakeCircle()
    
17.     Dim ent As ResultBuffer
    
18.     Set ent = New ResultBuffer
    
19.     ent.AddTypedValue 0, "CIRCLE"
    
20.     Dim pt1(0 To 2) As Double
    
21.     ent.AddTypedValue 10, pt1 ' 圆心
    
22.     ent.AddTypedValue 40, 3.5 ' 半径
    
23.     Debug.Print AcdbEntMake(ent)
    
24. End Sub

' 创建圆<br /> Sub testAcdbEntMakeCircle()<br />     Dim ct(0 To 2) As Integer<br />     Dim cv(0 To 2) As Variant<br />     ct(0) = 0<br />     cv(0) = "CIRCLE"<br />     Dim pt1(0 To 2) As Double<br />     ct(1) = 10 ' 圆心<br />     cv(1) = pt1<br />     ct(2) = 40 ' 半径<br />     cv(2) = 3.5<br />     Debug.Print AcdbEntMake(ct, cv)<br /> End Sub<br /> <br /> ' 创建圆-新版<br /> Sub testAcdbEntMakeCircle()<br />     Dim ent As ResultBuffer<br />     Set ent = New ResultBuffer<br />     ent.AddTypedValue 0, "CIRCLE"<br />     Dim pt1(0 To 2) As Double<br />     ent.AddTypedValue 10, pt1 ' 圆心<br />     ent.AddTypedValue 40, 3.5 ' 半径<br />     Debug.Print AcdbEntMake(ent)<br /> End Sub

1. '插入块
   
2. Sub testAcdbEntMakeInsert()
   
3.     Dim ct(0 To 2) As Integer
   
4.     Dim cv(0 To 2) As Variant
   
5.     ct(0) = 0
   
6.     cv(0) = "INSERT"
   
7.     ct(1) = 2 ' 名称
   
8.     cv(1) = "Block"
   
9.     Dim pt(0 To 2) As Double
   
10.     ct(2) = 10 ' 位置
    
11.     cv(2) = pt
    
12.    Debug.Print AcdbEntMake(ct, cv)
    
13. End Sub

'插入块<br /> Sub testAcdbEntMakeInsert()<br />     Dim ct(0 To 2) As Integer<br />     Dim cv(0 To 2) As Variant<br />     ct(0) = 0<br />     cv(0) = "INSERT"<br />     ct(1) = 2 ' 名称<br />     cv(1) = "Block"<br />     Dim pt(0 To 2) As Double<br />     ct(2) = 10 ' 位置<br />     cv(2) = pt<br />    Debug.Print AcdbEntMake(ct, cv)<br /> End Sub

1. ' 创建直线
   
2. Sub testAcdbEntMakeLine()
   
3.     Dim ct(0 To 2) As Integer
   
4.     Dim cv(0 To 2) As Variant
   
5.     ct(0) = 0
   
6.     cv(0) = "LINE"
   
7.     Dim pt1(0 To 2) As Double
   
8.     ct(1) = 10 ' 起点
   
9.     cv(1) = pt1
   
10.     Dim pt2(0 To 2) As Double
    
11.     pt2(0) = 10
    
12.     ct(2) = 11 ' 端点
    
13.     cv(2) = pt2
    
14.     Debug.Print AcdbEntMake(ct, cv)
    
15. End Sub

' 创建直线<br /> Sub testAcdbEntMakeLine()<br />     Dim ct(0 To 2) As Integer<br />     Dim cv(0 To 2) As Variant<br />     ct(0) = 0<br />     cv(0) = "LINE"<br />     Dim pt1(0 To 2) As Double<br />     ct(1) = 10 ' 起点<br />     cv(1) = pt1<br />     Dim pt2(0 To 2) As Double<br />     pt2(0) = 10<br />     ct(2) = 11 ' 端点<br />     cv(2) = pt2<br />     Debug.Print AcdbEntMake(ct, cv)<br /> End Sub

1. ' 创建多行文字
   
2. Sub testAcdbEntMakeMText()
   
3.     Dim ct(0 To 4) As Integer
   
4.     Dim cv(0 To 4) As Variant
   
5.     ct(0) = 0
   
6.     cv(0) = "MTEXT"
   
7.     ct(1) = 100
   
8.     cv(1) = "AcDbEntity"
   
9.     ct(2) = 100
   
10.     cv(2) = "AcDbMText"
    
11.     Dim pt(0 To 2) As Double
    
12.     ct(3) = 10 ' 位置
    
13.     cv(3) = pt
    
14.     ct(4) = 1 ' 内容
    
15.     cv(4) = "MText"
    
16.     Debug.Print AcdbEntMake(ct, cv)
    
17. End Sub

' 创建多行文字<br /> Sub testAcdbEntMakeMText()<br />     Dim ct(0 To 4) As Integer<br />     Dim cv(0 To 4) As Variant<br />     ct(0) = 0<br />     cv(0) = "MTEXT"<br />     ct(1) = 100<br />     cv(1) = "AcDbEntity"<br />     ct(2) = 100<br />     cv(2) = "AcDbMText"<br />     Dim pt(0 To 2) As Double<br />     ct(3) = 10 ' 位置<br />     cv(3) = pt<br />     ct(4) = 1 ' 内容<br />     cv(4) = "MText"<br />     Debug.Print AcdbEntMake(ct, cv)<br /> End Sub

1. ' 创建点
   
2. Sub testAcdbEntMakePoint()
   
3.     Dim ct(0 To 1) As Integer
   
4.     Dim cv(0 To 1) As Variant
   
5.     ct(0) = 0
   
6.     cv(0) = "POINT"
   
7.     Dim pt1(0 To 2) As Double
   
8.     ct(1) = 10 ' 位置
   
9.     cv(1) = pt1
   
10.     Debug.Print AcdbEntMake(ct, cv)
    
11. End Sub

' 创建点<br /> Sub testAcdbEntMakePoint()<br />     Dim ct(0 To 1) As Integer<br />     Dim cv(0 To 1) As Variant<br />     ct(0) = 0<br />     cv(0) = "POINT"<br />     Dim pt1(0 To 2) As Double<br />     ct(1) = 10 ' 位置<br />     cv(1) = pt1<br />     Debug.Print AcdbEntMake(ct, cv)<br /> End Sub

1. ' 创建多段线
   
2. Sub testAcdbEntMakePolyline()
   
3.     Dim ct(0 To 5) As Integer
   
4.     Dim cv(0 To 5) As Variant
   
5.     ct(0) = 0
   
6.     cv(0) = "LWPOLYLINE"
   
7.     ct(1) = 100
   
8.     cv(1) = "AcDbEntity"
   
9.     ct(2) = 100
   
10.     cv(2) = "AcDbPolyline"
    
11.     ct(3) = 90 ' 顶点数
    
12.     cv(3) = 2
    
13.     Dim pt1(0 To 1) As Double
    
14.     ct(4) = 10 ' 顶点
    
15.     cv(4) = pt1
    
16.     Dim pt2(0 To 1) As Double
    
17.     pt2(0) = 10
    
18.     ct(5) = 10 ' 顶点
    
19.     cv(5) = pt2
    
20.     Debug.Print AcdbEntMake(ct, cv)
    
21. End Sub

' 创建多段线<br /> Sub testAcdbEntMakePolyline()<br />     Dim ct(0 To 5) As Integer<br />     Dim cv(0 To 5) As Variant<br />     ct(0) = 0<br />     cv(0) = "LWPOLYLINE"<br />     ct(1) = 100<br />     cv(1) = "AcDbEntity"<br />     ct(2) = 100<br />     cv(2) = "AcDbPolyline"<br />     ct(3) = 90 ' 顶点数<br />     cv(3) = 2<br />     Dim pt1(0 To 1) As Double<br />     ct(4) = 10 ' 顶点<br />     cv(4) = pt1<br />     Dim pt2(0 To 1) As Double<br />     pt2(0) = 10<br />     ct(5) = 10 ' 顶点<br />     cv(5) = pt2<br />     Debug.Print AcdbEntMake(ct, cv)<br /> End Sub

1. ' 创建文字
   
2. Sub testAcdbEntMakeText()
   
3.     Dim ct(0 To 3) As Integer
   
4.     Dim cv(0 To 3) As Variant
   
5.     ct(0) = 0
   
6.     cv(0) = "TEXT"
   
7.     Dim pt1(0 To 2) As Double
   
8.     ct(1) = 10 ' 位置
   
9.     cv(1) = pt1
   
10.     ct(2) = 40 ' 高度
    
11.     cv(2) = 2
    
12.     ct(3) = 1 ' 内容
    
13.     cv(3) = "Text"
    
14.     Debug.Print AcdbEntMake(ct, cv)
    
15. End Sub

' 创建文字<br /> Sub testAcdbEntMakeText()<br />     Dim ct(0 To 3) As Integer<br />     Dim cv(0 To 3) As Variant<br />     ct(0) = 0<br />     cv(0) = "TEXT"<br />     Dim pt1(0 To 2) As Double<br />     ct(1) = 10 ' 位置<br />     cv(1) = pt1<br />     ct(2) = 40 ' 高度<br />     cv(2) = 2<br />     ct(3) = 1 ' 内容<br />     cv(3) = "Text"<br />     Debug.Print AcdbEntMake(ct, cv)<br /> End Sub

2014.07.25
修正AcedGrRead的BUG。
2014.06.19
原来版本部分函数已更改，新增ResultBuffer和TypedValue类处理ARX的resbuf结构。
支持R2004-R2014版本的AutoCAD32位版本。

注：函数库在R2007测试通过，理论上在R2008、R2009的32版本可以通用，其它版本的将于后续发布。
增加了R2010的32位版本mccomarx18，R2011、R2012的可以通用，但没测试。
增加了R2004的32位版本mccomarx16，R2005、R2006的可以通用，但没测试。

efan2000

1000次创建圆的速度

1. Sub test10000()
   
2.     Dim t0 As Double    t0 = ThisDrawing.GetVariable("CDATE")
   
3.     Dim i As Integer
   
4.     For i = 1 To 10000
   
5.         testAcdbEntMakeCircle
   
6.     Next
   
7.     Dim t1 As Double
   
8.     t1 = ThisDrawing.GetVariable("CDATE")
   
9.     Dim str As String
   
10.     Debug.Print AcdbRToS((t1 - t0) * 1000000#, 2, 6, str)
    
11.     Debug.Print "EntMakeCircle: " & str
    
12.     t0 = ThisDrawing.GetVariable("CDATE")
    
13.     For i = 1 To 10000
    
14.         Dim c(0 To 2) As Double
    
15.         ThisDrawing.ModelSpace.AddCircle c, 3.5
    
16.     Next
    
17.     t1 = ThisDrawing.GetVariable("CDATE")
    
18.     Debug.Print AcdbRToS((t1 - t0) * 1000000#, 2, 6, str)
    
19.     Debug.Print "AddCircle: " & str
    
20. End Sub
    
21. 
    
22. ' 创建圆
    
23. Sub testAcdbEntMakeCircle()
    
24.     Dim ct(0 To 2) As Integer
    
25.     Dim cv(0 To 2) As Variant
    
26.     ct(0) = 0
    
27.     cv(0) = "CIRCLE"
    
28.     Dim pt1(0 To 2) As Double
    
29.     ct(1) = 10 ' 圆心
    
30.     cv(1) = pt1
    
31.     ct(2) = 40 ' 半径
    
32.     cv(2) = 3.5
    
33.     AcdbEntMake ct, cv
    
34.     'Debug.Print AcdbEntMake(ct, cv)
    
35. End Sub

Sub test10000()<br />     Dim t0 As Double    t0 = ThisDrawing.GetVariable("CDATE")<br />     Dim i As Integer<br />     For i = 1 To 10000<br />         testAcdbEntMakeCircle<br />     Next<br />     Dim t1 As Double<br />     t1 = ThisDrawing.GetVariable("CDATE")<br />     Dim str As String<br />     Debug.Print AcdbRToS((t1 - t0) * 1000000#, 2, 6, str)<br />     Debug.Print "EntMakeCircle: " & str<br />     t0 = ThisDrawing.GetVariable("CDATE")<br />     For i = 1 To 10000<br />         Dim c(0 To 2) As Double<br />         ThisDrawing.ModelSpace.AddCircle c, 3.5<br />     Next<br />     t1 = ThisDrawing.GetVariable("CDATE")<br />     Debug.Print AcdbRToS((t1 - t0) * 1000000#, 2, 6, str)<br />     Debug.Print "AddCircle: " & str<br /> End Sub<br /> <br /> ' 创建圆<br /> Sub testAcdbEntMakeCircle()<br />     Dim ct(0 To 2) As Integer<br />     Dim cv(0 To 2) As Variant<br />     ct(0) = 0<br />     cv(0) = "CIRCLE"<br />     Dim pt1(0 To 2) As Double<br />     ct(1) = 10 ' 圆心<br />     cv(1) = pt1<br />     ct(2) = 40 ' 半径<br />     cv(2) = 3.5<br />     AcdbEntMake ct, cv<br />     'Debug.Print AcdbEntMake(ct, cv)<br /> End Sub

输出：
5100
EntMakeCircle: 1.102686
5100
AddCircle: 2.693385
5100
EntMakeCircle: 1.199543
5100
AddCircle: 4.481524
5100
EntMakeCircle: 1.333654
5100
AddCircle: 6.210059
可以看出acdbEntMake创建圆的速度比传统的创建圆快。

yshf

但还是比Lisp的entmake 慢

2. (defun c:TT()
   
3.     (setq t0 (getvar "cdate"))
   
4.     (repeat 1000
   
5.         (entmake (list '(0 . "circle")
   
6.                        '(10  0 0 0 )
   
7.                         '(40 . 3.5)
   
8.                  )
   
9.         )
   
10.     )
    
11.     (setq t1 (getvar "cdate")
    
12.           dt (* 1e6 (- t1 t0))
    
13.     )
    
14.     (princ (strcat "\n共耗时:" (rtos dt 2 6)))
    
15.     (princ)
    
16. )

(defun c:TT()<br />     (setq t0 (getvar "cdate"))<br />     (repeat 1000<br />         (entmake (list '(0 . "circle")<br />                        '(10  0 0 0 )<br />                         '(40 . 3.5)<br />                  )<br />         )<br />     )<br />     (setq t1 (getvar "cdate")<br />           dt (* 1e6 (- t1 t0))<br />     )<br />     (princ (strcat "\n共耗时:" (rtos dt 2 6)))<br />     (princ)<br /> )

命令: TT
共耗时:0.111759

命令:
命令: TT
共耗时:0.108033

命令:
命令: TT
共耗时:0.122935

yshf

生成10000个圆耗时测试，时间单位为秒：
命令: tt

共耗时:1.139939

命令:
命令: tt

共耗时:1.139939

命令:
命令: tt

共耗时:1.154840

wwswwswws

谢谢分享！好东西，下一个收藏。希望2010及以后版本的，我用的是AutoCAD 2010

efan2000

yshf 发表于 2013-11-16 20:53
生成10000个圆耗时测试，时间单位为秒：
命令: tt

可以搭个环境测试下，每个人的电脑配置、CAD版本都不同，测试结果会有偏差，只能做为参照。

efan2000

创建块的示例

1. ' 创建块
   
2. Sub testAcdbEntMakeBlock()
   
3.     Dim ct(0 To 3) As Integer
   
4.     Dim cv(0 To 3) As Variant
   
5.     ct(0) = 0
   
6.     cv(0) = "BLOCK"
   
7.     ct(1) = 2 ' 名称
   
8.     cv(1) = "Block"
   
9.     Dim pt(0 To 2) As Double
   
10.     ct(2) = 10 ' 基点
    
11.     cv(2) = pt
    
12.     ct(3) = 70 ' 标记
    
13.     cv(3) = 0
    
14.     Dim r As Integer
    
15.     r = AcdbEntMake(ct, cv)
    
16.     Debug.Print r
    
17.     If r = 5100 Then
    
18.         testAcdbEntMakeCircle
    
19.         testAcdbEntMakeEndBlock
    
20.     End If
    
21. End Sub
    
22. 
    
23. ' 创建圆
    
24. Sub testAcdbEntMakeCircle()
    
25.     Dim ct(0 To 2) As Integer
    
26.     Dim cv(0 To 2) As Variant
    
27.     ct(0) = 0
    
28.     cv(0) = "CIRCLE"
    
29.     Dim pt1(0 To 2) As Double
    
30.     ct(1) = 10 ' 圆心
    
31.     cv(1) = pt1
    
32.     ct(2) = 40 ' 半径
    
33.     cv(2) = 3.5
    
34.     Debug.Print AcdbEntMake(ct, cv)
    
35. End Sub
    
36. 
    
37. ' 结束块
    
38. Sub testAcdbEntMakeEndBlock()
    
39.     Dim ct(0 To 0) As Integer
    
40.     Dim cv(0 To 0) As Variant
    
41.     ct(0) = 0
    
42.     cv(0) = "ENDBLK"
    
43.     Debug.Print AcdbEntMake(ct, cv)
    
44.     ' 正常情况下，结果为RTKword = -5005
    
45.     ' 通过AcedGetInput，获取块名称
    
46.     Dim s As String
    
47.     Debug.Print AcedGetInput(s)
    
48.     Debug.Print s
    
49. End Sub
    
50. 
    
51. ' 创建匿名块
    
52. Sub testAcdbEntMakeAnonymousBlock()
    
53.     Dim ct(0 To 3) As Integer
    
54.     Dim cv(0 To 3) As Variant
    
55.     ct(0) = 0
    
56.     cv(0) = "BLOCK"
    
57.     ct(1) = 2 ' 匿名块名称
    
58.     cv(1) = "*U"
    
59.     Dim pt(0 To 2) As Double
    
60.     ct(2) = 10 ' 基点
    
61.     cv(2) = pt
    
62.     ct(3) = 70 ' 匿名块标记
    
63.     cv(3) = 1
    
64.     Dim r As Integer
    
65.     r = AcdbEntMake(ct, cv)
    
66.     Debug.Print r
    
67.     If r = 5100 Then
    
68.         testAcdbEntMakeCircle
    
69.         testAcdbEntMakeEndBlock
    
70.     End If
    
71. End Sub

' 创建块<br /> Sub testAcdbEntMakeBlock()<br />     Dim ct(0 To 3) As Integer<br />     Dim cv(0 To 3) As Variant<br />     ct(0) = 0<br />     cv(0) = "BLOCK"<br />     ct(1) = 2 ' 名称<br />     cv(1) = "Block"<br />     Dim pt(0 To 2) As Double<br />     ct(2) = 10 ' 基点<br />     cv(2) = pt<br />     ct(3) = 70 ' 标记<br />     cv(3) = 0<br />     Dim r As Integer<br />     r = AcdbEntMake(ct, cv)<br />     Debug.Print r<br />     If r = 5100 Then<br />         testAcdbEntMakeCircle<br />         testAcdbEntMakeEndBlock<br />     End If<br /> End Sub<br /> <br /> ' 创建圆<br /> Sub testAcdbEntMakeCircle()<br />     Dim ct(0 To 2) As Integer<br />     Dim cv(0 To 2) As Variant<br />     ct(0) = 0<br />     cv(0) = "CIRCLE"<br />     Dim pt1(0 To 2) As Double<br />     ct(1) = 10 ' 圆心<br />     cv(1) = pt1<br />     ct(2) = 40 ' 半径<br />     cv(2) = 3.5<br />     Debug.Print AcdbEntMake(ct, cv)<br /> End Sub<br /> <br /> ' 结束块<br /> Sub testAcdbEntMakeEndBlock()<br />     Dim ct(0 To 0) As Integer<br />     Dim cv(0 To 0) As Variant<br />     ct(0) = 0<br />     cv(0) = "ENDBLK"<br />     Debug.Print AcdbEntMake(ct, cv)<br />     ' 正常情况下，结果为RTKword = -5005<br />     ' 通过AcedGetInput，获取块名称<br />     Dim s As String<br />     Debug.Print AcedGetInput(s)<br />     Debug.Print s<br /> End Sub<br /> <br /> ' 创建匿名块<br /> Sub testAcdbEntMakeAnonymousBlock()<br />     Dim ct(0 To 3) As Integer<br />     Dim cv(0 To 3) As Variant<br />     ct(0) = 0<br />     cv(0) = "BLOCK"<br />     ct(1) = 2 ' 匿名块名称<br />     cv(1) = "*U"<br />     Dim pt(0 To 2) As Double<br />     ct(2) = 10 ' 基点<br />     cv(2) = pt<br />     ct(3) = 70 ' 匿名块标记<br />     cv(3) = 1<br />     Dim r As Integer<br />     r = AcdbEntMake(ct, cv)<br />     Debug.Print r<br />     If r = 5100 Then<br />         testAcdbEntMakeCircle<br />         testAcdbEntMakeEndBlock<br />     End If<br /> End Sub

wuyunpeng888

太好了，下来试试

wwswwswws

请问如何使用，我的系统是WIN7旗舰版32位，CAD是32位2010的，注册DLL是出现如下错误：

注册同名tlb文件也出现错误，请问一下高手该如何使用。

zzyong00

想法非常好，求支持x64各版本，最好开源，能让大家一起帮忙。。。