efan2000 发表于 2013-11-15 16:17:07

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

本帖最后由 efan2000 于 2014-7-27 19:35 编辑

通过封装ARX的函数，使之能够在VB、VBA或者.NET等中以COM方式访问。
acdbEntMake对应的COM函数为：Function AcdbEntMake(codetype, codevalue) As Long，其中codetype为整型的数组，codevalue为变体的数组，根据组码来确定类型。
' 创建圆弧
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
' 创建圆
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
'插入块
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
' 创建直线
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
' 创建多行文字
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
' 创建点
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
' 创建多段线
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
' 创建文字
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版本的AutoCAD32位版本。

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







efan2000 发表于 2013-11-15 16:42:44

本帖最后由 efan2000 于 2013-12-3 16:45 编辑

1000次创建圆的速度
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:05

本帖最后由 yshf 于 2013-11-16 20:48 编辑

但还是比Lisp的entmake 慢(defun c:TT()
    (setq t0 (getvar "cdate"))
    (repeat 1000
      (entmake (list '(0 . "circle")
                     '(100 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:31

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

共耗时:1.139939

命令:
命令: tt

共耗时:1.139939

命令:
命令: tt

共耗时:1.154840

wwswwswws 发表于 2013-11-17 08:46:49

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

efan2000 发表于 2013-11-18 11:10:22

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



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

efan2000 发表于 2013-11-18 11:41:02

创建块的示例
' 创建块
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

wuyunpeng888 发表于 2014-7-28 09:39:33

太好了，下来试试

wwswwswws 发表于 2014-9-28 17:21:32

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

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

zzyong00 发表于 2014-9-28 23:30:43

想法非常好，求支持x64各版本，最好开源，能让大家一起帮忙。。。
页: [1] 2
查看完整版本: ARX的COM函数库之实体篇(acdbEntMake)