标签：Documents bb fwpt 按户 Application ThisDrawing 户型图 line CAD

从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

标签：Documents,bb,fwpt,按户,Application,ThisDrawing,户型图,line,CAD
来源： https://www.cnblogs.com/jiongya99/p/15477713.html

本站声明： 1. iCode9 技术分享网（下文简称本站）提供的所有内容，仅供技术学习、探讨和分享；
2. 关于本站的所有留言、评论、转载及引用，纯属内容发起人的个人观点，与本站观点和立场无关；
3. 关于本站的所有言论和文字，纯属内容发起人的个人观点，与本站观点和立场无关；
4. 本站文章均是网友提供，不完全保证技术分享内容的完整性、准确性、时效性、风险性和版权归属；如您发现该文章侵犯了您的权益，可联系我们第一时间进行删除；
5. 本站为非盈利性的个人网站，所有内容不会用来进行牟利，也不会利用任何形式的广告来间接获益，纯粹是为了广大技术爱好者提供技术内容和技术思想的分享性交流网站。