CAD VBA（6.0、7.1）合并DWG文件及合并特定图层（代码已更新）

本文为按绝对坐标合并dwg，若需按相对坐标合并dwg图参考另一篇文章：

https://blog.csdn.net/yongshiqq/article/details/134954426

一、合并多个DWG方案，代码如下：

（调用win32 API函数实现如下界面：弹出对话框选择待合并文件，选择合并后文件保存路径）

Sub 合并DWG()
Dim sel As AcadSelectionSet
Dim ljwj As String, lj As String, zong As String
Dim myzong As AcadDocument
Set myzong = Documents.Add(zong)
Dim arr() As Object
Dim obj As AcadObject
lj ="d:"'改成你的文件夹路径
ljwj = Dir(lj & "\*.dwg")
MsgBox "请选择合并后文件储存路径", , "版权所有qq:443440204"
ThisDrawing.SaveAs "E:\总.dwg"'改成你的总文件路径带文件名
Dim lay As AcadLayer
Do While ljwj <> ""
     Set mydqwj = Documents.Open(lj & "\" & ljwj)
     Set sel = ThisDrawing.SelectionSets.Add("mysel")
     sel.Select acSelectionSetAll
     If sel.Count > 0 Then
         ReDim arr(sel.Count - 1)
         ReDim newarr(sel.Count - 1)
         For I = 0 To sel.Count - 1
            Set arr(I) = sel.Item(I)
         Next I
         dqwj = lj & "\" & ljwj
          mydqwj.CopyObjects arr, myzong.ModelSpace
      End If
      mydqwj.Close
      ljwj = Dir
      Erase arr
     sel.Delete
      dqwj = ""
      I = ""
Loop

lj = ""
ljwj = ""
zong = ""
Set JZD = Nothing
Set myzong = Nothing
Set mydqwj = Nothing
ThisDrawing.Regen acActiveViewport
ZoomExtents

MsgBox "已完成!" & vbCr & "qq:443440204", , "版权所有qq:443440204"
End Sub

二、合并多个DWG指定图层并剔除文字，代码如下： 

Sub 合并DWG指定图层不包含文字()
Dim sel As AcadSelectionSet
Dim ljwj As String, lj As String, zong As String
Dim ftype(0 To 10) As Integer, fdata(0 To 10) As Variant
ftype(0) = -4: fdata(0) = "<AND"
ftype(1) = 8: fdata(1) = "JZD"
ftype(2) = -4: fdata(2) = "<AND"
ftype(3) = -4: fdata(3) = "<NOT"
ftype(4) = 0: fdata(4) = "text"
ftype(5) = -4: fdata(5) = "NOT>"
ftype(6) = -4: fdata(6) = "<NOT"
ftype(7) = 0: fdata(7) = "mtext"
ftype(8) = -4: fdata(8) = "NOT>"
ftype(9) = -4: fdata(9) = "AND>"
ftype(10) = -4: fdata(10) = "AND>"
Dim myzong As AcadDocument
Set myzong = Documents.Add(zong)
Dim arr() As Object
Dim obj As AcadObject
lj =  "D:"'改成你的文件所在路径
ljwj = Dir(lj & "\*.dwg")
MsgBox "请选择合并后文件储存路径"
ThisDrawing.SaveAs "E:\总.dwg"'改成你的总文件路径带文件名
Dim lay As AcadLayer
For Each lay In ThisDrawing.Layers
    If lay.Name = "JZD" Then
        Set JZD = ThisDrawing.Layers("JZD")
        ThisDrawing.ActiveLayer = JZD
        JZD.color = acRed
        Exit For
    End If
Next lay
If ThisDrawing.ActiveLayer.Name <> "JZD" Then
    Set JZD = ThisDrawing.Layers.Add("JZD")
    ThisDrawing.ActiveLayer = JZD
    JZD.color = acRed
End If
Do While ljwj <> ""
     Set mydqwj = Documents.Open(lj & "\" & ljwj)
     Set sel = ThisDrawing.SelectionSets.Add("mysel")
     sel.Select acSelectionSetAll, , , ftype, fdata
     If sel.Count > 0 Then
         ReDim arr(sel.Count - 1)
         For I = 0 To sel.Count - 1
         Set arr(I) = sel.Item(I)
         Next I
         dqwj = lj & "\" & ljwj
          mydqwj.CopyObjects arr, myzong.ModelSpace
      End If
      mydqwj.Close
      ljwj = Dir
      Erase arr
     
      sel.Delete
      dqwj = ""
      I = ""
Loop

lj = ""
ljwj = ""
zong = ""
Set JZD = Nothing
Set myzong = Nothing
Set mydqwj = Nothing
ThisDrawing.Regen acActiveViewport
ZoomExtents
MsgBox "已完成！qq:443440204", , "版权所有qq443440204"
End Sub