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

efan2000 · 发表于 2013-11-15 16:17:00

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

copy

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

copy

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

copy

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

copy

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

copy

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

copy

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

copy

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

copy

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

2014.07.25
修正AcedGrRead的BUG。
2014.06.19
原来版本部分函数已更改，新增ResultBuffer和TypedValue类处理ARX的resbuf结构。
支持R2004-R2014版本的32位版本。
注：函数库在R2007测试通过，理论上在R2008、R2009的32版本可以通用，其它版本的将于后续发布。
增加了R2010的32位版本mccomarx18，R2011、R2012的可以通用，但没测试。
增加了R2004的32位版本mccomarx16，R2005、R2006的可以通用，但没测试。

本帖以下内容被隐藏保护；需要你回复后，才能看到！

游客，如果您要查看本帖隐藏内容请回复

efan2000 · 发表于 2013-11-15 16:42:00

1000次创建圆的速度

copy

Sub test10000()
    Dim t0 As Double    t0 = ThisDrawing.GetVariable("CDATE")
    Dim i As Integer
    For i = 1 To 10000
        testAcdbEntMakeCircle
    Next
    Dim t1 As Double
    t1 = ThisDrawing.GetVariable("CDATE")
    Dim str As String
    Debug.Print AcdbRToS((t1 - t0) * 1000000#, 2, 6, str)
    Debug.Print "EntMakeCircle: " & str
    t0 = ThisDrawing.GetVariable("CDATE")
    For i = 1 To 10000
        Dim c(0 To 2) As Double
        ThisDrawing.ModelSpace.AddCircle c, 3.5
    Next
    t1 = ThisDrawing.GetVariable("CDATE")
    Debug.Print AcdbRToS((t1 - t0) * 1000000#, 2, 6, str)
    Debug.Print "AddCircle: " & str
End Sub
 
 ' 创建圆
Sub testAcdbEntMakeCircle()
    Dim ct(0 To 2) As Integer
    Dim cv(0 To 2) As Variant
    ct(0) = 0
    cv(0) = "CIRCLE"
    Dim pt1(0 To 2) As Double
    ct(1) = 10 ' 圆心
    cv(1) = pt1
    ct(2) = 40 ' 半径
    cv(2) = 3.5
    AcdbEntMake ct, cv
    'Debug.Print AcdbEntMake(ct, cv)
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 · 发表于 2013-11-16 20:46:00

但还是比Lisp的entmake 慢

copy


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

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

yshf · 发表于 2013-11-16 20:53:00

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

wwswwswws · 发表于 2013-11-17 08:46:00

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

efan2000 · 发表于 2013-11-18 11:10:00

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

efan2000 · 发表于 2013-11-18 11:41:00

创建块的示例

copy

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