從ArcGIS中匯出的戶型圖是按層分開放置的，現根據要求將按戶合併一起，原計劃編寫lisp的，但一直沒有搞懂同時怎樣操作多個檔案，最終放棄了

VBA在Excel中很好用，但在CAD中的缺點較多，主要不太穩定，至於執行速度...資料實在多就慢慢等吧

本次程式很亂，演算法也很菜，且未多做標註，還好完美執行。其實記錄下來主要是除錯了很久，才搞定的多個圖互相複製圖形功能，下次使用可以照搬。

Sub HBall()
    Dim filepath As String
    filepath = ""
    Dim fhtx() As String
    Dim js As Long, aa As Integer, yn As Boolean
    js = 2
    yn = False
    
    filepath = InputBox("請輸入處理的資料所在資料夾" & vbCr & "（格式 D:\test\test ）:", "資料夾輸入")
    If filepath = "" Then
       Exit Sub
    End If
    
    Dim MyFile As Object
    On Error Resume Next
    Set MyFile = CreateObject("Scripting.FileSystemObject")
    
    Set xlapp = CreateObject("Excel.Application")
    Set wkb = xlapp.Workbooks.Open(filepath & "\戶型表格資訊.xlsm")
    xlapp.Visible = True
    xlapp.StatusBar = False
    Dim bdcdyh As String
    
    For js = 2 To wkb.sheets(1).usedrange.Rows.Count
        
        ReDim fhtx(0 To UBound(Split(wkb.sheets(1).cells(js, 4), ",")))
        fhtx = Split(wkb.sheets(1).cells(js, 4), ",")
        If UBound(fhtx) < 1 Then
            If Dir(filepath & "\戶型圖old\" & wkb.sheets(1).cells(js, 4) & ".dwg", 16) <> Empty Then
                MyFile.CopyFile filepath & "\戶型圖old\" & fhtx(0) & ".dwg", filepath & "\戶型圖ok\"
                 Name filepath & "\戶型圖ok\" & wkb.sheets(1).cells(js, 4) & ".dwg" As filepath & "\戶型圖ok\" & wkb.sheets(1).cells(js, 1) & ".dwg"
                'Name filepath & "\戶型圖old\" & wkb.sheets(1).cells(js, 4) & ".dwg" As filepath & "\戶型圖ok\" & wkb.sheets(1).cells(js, 4) & ".dwg"
                
            Else
                wkb.sheets(1).cells(js, 5) = "有未找到檔案！"
            End If
            
        Else
            For aa = 0 To UBound(fhtx)
                If Dir(filepath & "\戶型圖old\" & fhtx(aa) & ".dwg", 16) = Empty Then
                    wkb.sheets(1).cells(js, 5) = "有未找到檔案！"
                    yn = True
                    Exit For
                End If
            Next
            
            If UBound(fhtx) > 5 Then
                    wkb.sheets(1).cells(js, 5) = "超過6個，請補充6個以上！"
            End If
            
            If yn = False Then
                bdcdyh = wkb.sheets(1).cells(js, 1).Value
                Call FHTHB(fhtx, filepath, bdcdyh)
            End If

        End If

        yn = False
        xlapp.StatusBar = "程式執行進度： " & Round(js / wkb.sheets(1).usedrange.Rows.Count, 4) * 100 & "%"
    Next
    
    Set MyFile = Nothing
    Set wkb = Nothing
    Set xlapp = Nothing
    
    MsgBox ("完成資料處理！")
    xlapp.StatusBar = ""
    xlapp.StatusBar = False

End Sub

Sub FHTHB(ByRef hx() As String, filepath1 As String, bdcdyh1 As String)

    Dim xg1, xg2 As Double
    Dim tx1pt(0 To 2) As Double, tx2pt(0 To 2) As Double
    Dim fwpt_A(0 To 5) As Double, fwpt_B(0 To 5) As Double
    Dim aa, bb As Integer
    bb = 0
    Dim retObjects As Variant
    Dim ttt() As Object
    
    Dim SSet As AcadSelectionSet
    Dim Ft(0) As Integer, Fd(0)
    Ft(0) = 8: Fd(0) = "0"
    
    For aa = 0 To 5
        fwpt_A(aa) = -9000000
    Next
    
    ThisDrawing.Application.Documents.Open filepath1 & "\戶型圖old\" & hx(0) & ".dwg"
    ThisDrawing.Application.ZoomExtents
    Call Getall(fwpt_A(), 1)
    
    If UBound(hx) = 1 Then                       ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''2
        For aa = 0 To 5
            fwpt_B(aa) = -9000000
        Next
        ThisDrawing.Application.Documents.Open filepath1 & "\戶型圖old\" & hx(1) & ".dwg"
        ThisDrawing.Application.ZoomExtents
        Call Getall(fwpt_B(), 2)
        tx1pt(0) = fwpt_A(2)
        tx1pt(1) = fwpt_A(3) - (fwpt_A(5) - fwpt_A(1)) * 1.2
        tx1pt(2) = 0
        tx2pt(0) = fwpt_B(2)
        tx2pt(1) = fwpt_B(3)
        tx2pt(2) = 0
        Set SSet = ThisDrawing.Application.Documents(2).SelectionSets.Add(ThisDrawing.Application.Documents(2).Name)
        
        SSet.Select acSelectionSetAll    ', , , Ft, Fd
        ReDim ttt(0 To SSet.Count - 1)
        bb = 0
        For Each ent In SSet
            Set ttt(bb) = ent
            ttt(bb).Move tx2pt, tx1pt
            bb = bb + 1
        Next
        retObjects = ThisDrawing.Application.Documents(2).CopyObjects(ttt, ThisDrawing.Application.Documents(1).ModelSpace)
        ThisDrawing.Application.Documents(2).Close False
        ThisDrawing.Application.ZoomExtents
        
    Else
        For aa = 0 To 5                                                         ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''2
            fwpt_B(aa) = -9000000
        Next
        ThisDrawing.Application.Documents.Open filepath1 & "\戶型圖old\" & hx(1) & ".dwg"
        ThisDrawing.Application.ZoomExtents
        Call Getall(fwpt_B(), 2)
        tx1pt(0) = fwpt_A(2) + (fwpt_A(4) - fwpt_A(0)) * 1.2
        tx1pt(1) = fwpt_A(3)
        tx1pt(2) = 0
        tx2pt(0) = fwpt_B(2)
        tx2pt(1) = fwpt_B(3)
        tx2pt(2) = 0
        Set SSet = ThisDrawing.Application.Documents(2).SelectionSets.Add(ThisDrawing.Application.Documents(2).Name)
        
        SSet.Select acSelectionSetAll    ', , , Ft, Fd
        ReDim ttt(0 To SSet.Count - 1)
        bb = 0
        For Each ent In SSet
            Set ttt(bb) = ent
            ttt(bb).Move tx2pt, tx1pt
            bb = bb + 1
        Next
        retObjects = ThisDrawing.Application.Documents(2).CopyObjects(ttt, ThisDrawing.Application.Documents(1).ModelSpace)
        ThisDrawing.Application.Documents(2).Close False
        ThisDrawing.Application.ZoomExtents
         
        
        For aa = 0 To 5                                                         ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''3
            fwpt_B(aa) = -9000000
        Next
        ThisDrawing.Application.Documents.Open filepath1 & "\戶型圖old\" & hx(2) & ".dwg"
        ThisDrawing.Application.ZoomExtents
        Call Getall(fwpt_B(), 2)
        tx1pt(0) = fwpt_A(2)
        tx1pt(1) = fwpt_A(3) - (fwpt_A(5) - fwpt_A(1)) * 1.2
        tx1pt(2) = 0
        tx2pt(0) = fwpt_B(2)
        tx2pt(1) = fwpt_B(3)
        tx2pt(2) = 0
        Set SSet = ThisDrawing.Application.Documents(2).SelectionSets.Add(ThisDrawing.Application.Documents(2).Name)
        
        SSet.Select acSelectionSetAll    ', , , Ft, Fd
        ReDim ttt(0 To SSet.Count - 1)
        bb = 0
        For Each ent In SSet
            Set ttt(bb) = ent
            ttt(bb).Move tx2pt, tx1pt
            bb = bb + 1
        Next
        retObjects = ThisDrawing.Application.Documents(2).CopyObjects(ttt, ThisDrawing.Application.Documents(1).ModelSpace)
        ThisDrawing.Application.Documents(2).Close False
        ThisDrawing.Application.ZoomExtents
        
        If UBound(hx) > 2 Then
            For aa = 0 To 5                                                         ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''4
                fwpt_B(aa) = -9000000
            Next
            ThisDrawing.Application.Documents.Open filepath1 & "\戶型圖old\" & hx(3) & ".dwg"
            ThisDrawing.Application.ZoomExtents
            Call Getall(fwpt_B(), 2)
            tx1pt(0) = fwpt_A(2) + (fwpt_A(4) - fwpt_A(0)) * 1.2
            tx1pt(1) = fwpt_A(3) - (fwpt_A(5) - fwpt_A(1)) * 1.2
            tx1pt(2) = 0
            tx2pt(0) = fwpt_B(2)
            tx2pt(1) = fwpt_B(3)
            tx2pt(2) = 0
            Set SSet = ThisDrawing.Application.Documents(2).SelectionSets.Add(ThisDrawing.Application.Documents(2).Name)
        
            SSet.Select acSelectionSetAll    ', , , Ft, Fd
            ReDim ttt(0 To SSet.Count - 1)
            bb = 0
            For Each ent In SSet
                Set ttt(bb) = ent
                ttt(bb).Move tx2pt, tx1pt
                bb = bb + 1
            Next
            retObjects = ThisDrawing.Application.Documents(2).CopyObjects(ttt, ThisDrawing.Application.Documents(1).ModelSpace)
            ThisDrawing.Application.Documents(2).Close False
            ThisDrawing.Application.ZoomExtents
        End If
        
        
        If UBound(hx) > 3 Then
            For aa = 0 To 5                                                         ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''5
                fwpt_B(aa) = -9000000
            Next
            ThisDrawing.Application.Documents.Open filepath1 & "\戶型圖old\" & hx(4) & ".dwg"
            ThisDrawing.Application.ZoomExtents
            Call Getall(fwpt_B(), 2)
            tx1pt(0) = fwpt_A(2)
            tx1pt(1) = fwpt_A(3) - (fwpt_A(5) - fwpt_A(1)) * 2.4
            tx1pt(2) = 0
            tx2pt(0) = fwpt_B(2)
            tx2pt(1) = fwpt_B(3)
            tx2pt(2) = 0
            Set SSet = ThisDrawing.Application.Documents(2).SelectionSets.Add(ThisDrawing.Application.Documents(2).Name)
        
            SSet.Select acSelectionSetAll    ', , , Ft, Fd
            ReDim ttt(0 To SSet.Count - 1)
            bb = 0
            For Each ent In SSet
                Set ttt(bb) = ent
                ttt(bb).Move tx2pt, tx1pt
                bb = bb + 1
            Next
            retObjects = ThisDrawing.Application.Documents(2).CopyObjects(ttt, ThisDrawing.Application.Documents(1).ModelSpace)
            ThisDrawing.Application.Documents(2).Close False
            ThisDrawing.Application.ZoomExtents
        End If
        
        
        If UBound(hx) > 4 Then
            For aa = 0 To 5                                                         ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''6
                fwpt_B(aa) = -9000000
            Next
            ThisDrawing.Application.Documents.Open filepath1 & "\戶型圖old\" & hx(5) & ".dwg"
            ThisDrawing.Application.ZoomExtents
            Call Getall(fwpt_B(), 2)
            tx1pt(0) = fwpt_A(2) + (fwpt_A(4) - fwpt_A(0)) * 1.2
            tx1pt(1) = fwpt_A(3) - (fwpt_A(5) - fwpt_A(1)) * 2.4
            tx1pt(2) = 0
            tx2pt(0) = fwpt_B(2)
            tx2pt(1) = fwpt_B(3)
            tx2pt(2) = 0
            Set SSet = ThisDrawing.Application.Documents(2).SelectionSets.Add(ThisDrawing.Application.Documents(2).Name)
        
            SSet.Select acSelectionSetAll    ', , , Ft, Fd
            ReDim ttt(0 To SSet.Count - 1)
            bb = 0
            For Each ent In SSet
                Set ttt(bb) = ent
                ttt(bb).Move tx2pt, tx1pt
                bb = bb + 1
            Next
            retObjects = ThisDrawing.Application.Documents(2).CopyObjects(ttt, ThisDrawing.Application.Documents(1).ModelSpace)
            ThisDrawing.Application.Documents(2).Close False
            ThisDrawing.Application.ZoomExtents
        End If
        
        
     End If

    'ThisDrawing.Application.Documents(1).TextStyles.Item(0).fontFile = "C:\Windows\Fonts\simhei.ttf"
    ThisDrawing.Application.Documents(1).SaveAs filepath1 & "\戶型圖ok\" & bdcdyh1 & ".dwg"
    ThisDrawing.Application.Documents(1).Close False
    
End Sub

Sub Getall(ByRef fwpt() As Double, a As Integer)
    Dim ent As AcadEntity
    Dim line As AcadLine
    For Each ent In ThisDrawing.Application.Documents(a).ModelSpace
           
        If TypeOf ent Is AcadLine Then       '''''''''顏色
           Set line = ent
           If fwpt(0) = -9000000 Then
               If line.StartPoint(0) < line.EndPoint(0) Then
                   fwpt(0) = line.StartPoint(0)
                   fwpt(4) = line.EndPoint(0)
               Else
                   fwpt(0) = line.EndPoint(0)
                   fwpt(4) = line.StartPoint(0)
               End If
               
               If line.StartPoint(1) < line.EndPoint(1) Then
                   fwpt(1) = line.StartPoint(1)
                   fwpt(5) = line.EndPoint(1)
               Else
                   fwpt(1) = line.EndPoint(1)
                   fwpt(5) = line.StartPoint(1)
               End If

           Else ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
               If fwpt(0) > line.StartPoint(0) Then
                   fwpt(0) = line.StartPoint(0)
               ElseIf fwpt(4) < line.StartPoint(0) Then
                   fwpt(4) = line.StartPoint(0)
               End If
               
               If fwpt(0) > line.EndPoint(0) Then
                   fwpt(0) = line.EndPoint(0)
               ElseIf fwpt(4) < line.EndPoint(0) Then
                   fwpt(4) = line.EndPoint(0)
               End If
               
               If fwpt(1) > line.StartPoint(1) Then
                   fwpt(1) = line.StartPoint(1)
               ElseIf fwpt(5) < line.StartPoint(1) Then
                   fwpt(5) = line.StartPoint(1)
               End If
               
               If fwpt(1) > line.EndPoint(1) Then
                   fwpt(1) = line.EndPoint(1)
               ElseIf fwpt(5) < line.EndPoint(1) Then
                   fwpt(5) = line.EndPoint(1)
               End If
  
           End If
        End If

     Next ent
     
     fwpt(2) = (fwpt(0) + fwpt(4)) / 2
     fwpt(3) = (fwpt(1) + fwpt(5)) / 2

End Sub