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
