excel vba 利用AutoCAD DBX 技术将一个dwg/dxf文件的内容复制到另一个dwg/dxf文件

Option Explicit
Const acadProgID = "AutoCAD.Application"
Const dbxProgID = "ObjectDBX.AxDbDocument" '   Set objDbx = GetInterfaceObject("ObjectDBX.AxDbDocument.16")

'@返回空的话用isempty判断
Public Function MyCopyObjects(dbxResource As Variant, dbxTarget As Variant, Optional detlaX As Double = 0#, Optional detlaY As Double = 0#) As Variant
    Dim ents() As Object, copiedObjs As Variant, i As Long
    If dbxResource.ModelSpace.Count > 0 Then
        ReDim ents(0 To dbxResource.ModelSpace.Count - 1)
        For i = 0 To dbxResource.ModelSpace.Count - 1
            Set ents(i) = dbxResource.ModelSpace.Item(i)
        Next
        copiedObjs = dbxResource.CopyObjects(ents, dbxTarget.ModelSpace)
        For i = LBound(copiedObjs) To UBound(copiedObjs)
            copiedObjs(i).Move C3P(), C3P(detlaX, detlaY)
        Next i
    End If
    MyCopyObjects = copiedObjs
End Function

Public Sub Test()
    Dim acadApp As AcadApplication, v As String, objDbx As AxDbDocument, pt As Variant, objdbx1 As AxDbDocument, flag As Boolean
    pt = C3P(): v = GetAcadCurVer()
    Set acadApp = VBA.CreateObject(acadProgID & v, vbNullString)
    On Error Resume Next
    Set objDbx = acadApp.GetInterfaceObject(dbxProgID & v)
    Set objdbx1 = acadApp.GetInterfaceObject(dbxProgID & v)
    Dim fn As String: fn = "D:\下载\传输表格1215.2025_12_23_205641.dxf"
    Dim fn1 As String: fn1 = "C:\Users\nslov\Desktop\Test.dxf"
    If VBA.Dir(fn1) <> "" Then VBA.Kill fn1
    Dim blk As String: blk = "C:\Users\nslov\Desktop\Drawing1.dwg"
    objdbx1.Open blk
    '将内容复制到另外一个文件
    objDbx.DxfIn fn
    MyCopyObjects objdbx1, objDbx, 1000, 500
    objDbx.DxfOut fn1
    If Not (objDbx Is Nothing) Then Set objDbx = Nothing
    If Not (objdbx1 Is Nothing) Then Set objdbx1 = Nothing
    acadApp.Quit: If Not (acadApp Is Nothing) Then Set acadApp = Nothing
    MsgBox "ok", vbInformation
End Sub

Public Function C3P(Optional x As Double = 0#, Optional y As Double = 0#, Optional z As Double = 0#) As Variant
    Dim rtns(0 To 2) As Double
    rtns(0) = x
    rtns(1) = y
    rtns(2) = z
    C3P = rtns
End Function

Public Function GetAcadCurVer() As String
    Dim v As String, wsh As Object, regKeyPath As String, regValueName As String
    ' 设置注册表路径和值名
    regKeyPath = "HKEY_CURRENT_USER\Software\Autodesk\AutoCAD"
    regValueName = "CurVer"
    ' 创建注册表对象
    Set wsh = CreateObject("WScript.Shell")
    ' 读取注册表值
    v = VBA.Left(VBA.Replace(wsh.RegRead(regKeyPath & "\" & regValueName), "R", ""), 2)
    ' 输出注册表值
    Set wsh = Nothing
    GetAcadCurVer = "." & v
End Function