合并CAD文件

'这篇是批量合并CAD文件的VBA程序，就是把一个文件夹里的所有的CAD文件合并到当前的工作空间中。可以根据需求来进行修改。思路就是记录文件路径、创建选择集、循环加载文件、把文件的内容添加到当前工作空间中，还有不对的地方请指教。

Private Sub MergeCAD()

Dim CommonDialog1 As CommonDialog

Set CommonDialog1 = New CommonDialog

CommonDialog1.CancelError = True

On Error GoTo ErrHandler

'读取文件目录，影藏窗体

With CommonDialog1

.Filter = "*.dwg|*.dwg"

.ShowSave

Dim A As String

A = Trim(.FileName)

i = InStrRev(A, "\")

MyPath = Mid(A, 1, i)

End With

UserForm1.hide

Dim MyFile, MyName As String

Dim insertionPnt(0 To 2) As Double

Dim blockRefObj As AcadBlockReference

'删除选择集创建选择集

On Error Resume Next

Call ThisDrawing.SelectionSets("MyssTx").Delete

On Error Resume Next

Set myselecttx = ThisDrawing.SelectionSets.Add("MyssTx")

If Err Then

Err.Clear

Set myselecttx = ThisDrawing.SelectionSets("MyssTx")

End If

MyFile = Dir(MyPath & "*.dwg")

Do While MyFile <> "" ' 开始循环。

insertionPnt(0) = 0#: insertionPnt(1) = 0#: insertionPnt(2) = 0# 'CAD图形的参照原点，如果你的图像的参照原点不是这个，请更改

On Error Resume Next

If FileLen(MyPath & MyFile) < 2048000 Then '这里是限制了文件的大小，不可设置太大，如果文件太大会影响速度，这个值就看个人需要了，也可以不设置

Set blockRefObj = ThisDrawing.ModelSpace.InsertBlock(insertionPnt, MyPath & MyFile, 1#, 1#, 1#, 0)

blockRefObj.Explode: blockRefObj.Delete

End If

MyFile = Dir

Loop

myselecttx.Delete

ErrHandler:

'用户按了"取消"按钮。

Exit Sub

End Sub

七月寒翎沐