批量合成CAD图（可指定插入点、行列距）

指定插入点和行列距离，可一键合并CAD图到一个总图，效果图如下：

?

''仅展示部分代码，完整代码联系本博
Sub 合并cad按行列排()
'定义每行文件数dim number_row，定义右间隔distance_x 下间隔distance_y(注意：下间隔distance_y必须大于待合并图层的最大高度，否则会出现压盖)
Dim number_row As Integer: number_row = 8
Dim distance_x As Double, distance_y As Double
distance_x = 1000: distance_y = 5000
'Dim distance_y_arr(0 To 2) As Double
'distance_y_arr(0) = 0: distance_y_arr(1) = distance_y
'定义文档上下间距
Dim updistance As Double
'定义计数器
Dim counter
'定义角1 pt_one系统获取，不能设置为数组格式
Dim pt_one As Variant
'定义角2 pt_two(0to1) x=角1y=角3y, move 函数的两个点。0#意思是把这个0转成双精度赋值。0!为单精度
Dim pt_two(0 To 2) As Double: pt_two(2) = 0#
'定义角3 pt_three(0to1) 系统获取，不能设置为数组格式,设置双精度会提示
Dim pt_three As Variant
'定义角4 pt_four_arr(0to1) x=角3y=角1,设置为数组格式变体变量，否则提示错误
Dim pt_four_arr(0 To 1) As Double
Dim pt_zero(0 To 2) As Double: pt_zero(0) = 0: pt_zero(1) = 0:
'定义换行角 pt_column_arr(0to1) move函数的两个点
Dim pt_column_arr(0 To 2) As Double: pt_column_arr(2) = 0#
Dim ent As AcadEntity
Dim arr() As Object
Dim i As Integer
'定义文件file_small
Dim file_small As AcadDocument
Dim file_small_name As String
Dim file_small_fullname As String
'定义文件file_big
Dim file_big As AcadDocument
'定义文件夹folder_small
Dim folder_small As String
'folder_small = GOFOLDER
folder_small = GOFOLDER
'Set file_big = Documents.Add("name_string")
Set file_big = Documents.Add("name_string")
'ActiveDocument.SaveAs GSFN
file_big.SaveAs GSFN
'定义目标点 goalpoint ,getpoint不能给数组赋值，应设置为变体变量
Dim goalpoint  As Variant
 '目标点 = GetPoint()
goalpoint = ThisDrawing.Utility.GetPoint(, "请指定插入点位置: ")
'file_small文件名= Dir(folder_small&"\*.dwg")
file_small_name = Dir(folder_small & "\*.dwg")


'Do开始循环目录内文件
Do While file_small_name <> ""
    ' 打开文件documents.Open file_small
    file_small_fullname = folder_small & "\" & file_small_name
    Set file_small = Documents.Open(file_small_fullname)
    ' 计数器 = 计数器 + 1
    counter = counter + 1
''    If counter = 11 Then
'''    Stop
''    ElseIf counter = 12 Then
''    Stop
'
'    End If
    ' 更新四个角坐标放入数组
    ' pt_one(0to1)系统获取
     pt_one = ThisDrawing.GetVariable("extmin")
    ' pt_three(0to1) 系统获取
     pt_three = ThisDrawing.GetVariable("extmax")
    ' pt_two(0to1) x=角1y=角3y
     pt_two(0) = pt_one(0): pt_two(1) = pt_three(1)
    ' pt_four_arr(0to1) x=角3y=角1
    pt_four_arr(0) = pt_three(0): pt_four_arr(1) = pt_one(1)
    'If 计数器 = 1 Then
"********************************************************************************
"********************************************************************************

"**完整代码联系本博

"***************************************************************************
"****************************************************************************************
    End If
    '创建选择集,复制到总文件，关闭当前文件
    ' 选择集放入ent数组Copyobjects 到总文件
    '  当前file_small.Close
    ' 文件 = Dir
   'Loop结束循环
   
        Set sel = creatsel()
        sel.Select acSelectionSetAll
        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
            file_small.CopyObjects arr, file_big.ModelSpace
        End If
          Erase arr
          file_small.Close False
          file_small_name = Dir
Loop
'file_big.Save
ZoomExtents
ThisDrawing.Save
MsgBox "已完成!" & vbCr & "qq:443440204", , "版权所有qq:443440204"
End Sub

?