admin管理员组文章数量:1574054
本文为按绝对坐标合并dwg,若需按相对坐标合并dwg图参考另一篇文章:
https://blog.csdn/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
版权声明:本文标题:CAD VBA(6.0、7.1)合并DWG文件及合并特定图层(代码已更新) 内容由热心网友自发贡献,该文观点仅代表作者本人, 转载请联系作者并注明出处:https://m.elefans.com/xitong/1727766014a1128484.html, 本站仅提供信息存储空间服务,不拥有所有权,不承担相关法律责任。如发现本站有涉嫌抄袭侵权/违法违规的内容,一经查实,本站将立刻删除。
发表评论