将图纸拆分程序，求助。
本帖最后由 jepvyg 于 2024-12-16 19:23 编辑有高手能帮忙看下吗。
为了画图方便，将所有的图都放一个文件里了。现在需要将一个个的图都独立出来，用图号命名。
忙了几天，东拼西凑做了个程序。可是运行的速度却很慢（主要是在复制阶段），还不如Crtl+C 加CTRL +V快。吐血了。
跪求大神了！！
Option Explicit
Sub Explore()
Dim acadApp As AcadApplication
Dim acadDoc As AcadDocument
Dim destDoc As AcadDocument
Dim templatePath As String, txtStr As String, tName As String, tPath As String
Dim ss As AcadSelectionSet
Dim k As Integer
Dim objCollection() As Object
Dim filterType(0) As Integer, filterData(0) As Variant
'防止错误
On Error Resume Next
'如果CAD开了，就取得，没有就新开。
Set acadApp = GetObject(, "AutoCAD.Application")
If acadApp Is Nothing Then
Set acadApp = CreateObject("AutoCAD.Application")
End If
' CAD可见
acadApp.Visible = True
On Error Resume Next
'首先确认要分解的图纸图号。
ThisDrawing.Utility.Prompt "请拾取新图纸图号"
'安全创建选择集***********************
If Not IsNull(ThisDrawing.SelectionSets.Item("this")) Then
Set ss = ThisDrawing.SelectionSets.Item("this")
ss.Delete
End If
Set ss = ThisDrawing.SelectionSets.Add("this")
filterType(0) = 0
filterData(0) = "text,mtext"
ss.SelectOnScreen filterType, filterData '点选输入图号
'得到选择的图号。
For k = 0 To ss.Count - 1
txtStr = ss.Item(k).ObjectName
If txtStr = "AcDbMText" Then
tName = MtextStringClearFormat(ss.Item(k).TextString)
Else: tName = ss.Item(k).TextString
End If
Next k
' 创建选择集并让用户选择实体
If Not IsNull(ThisDrawing.SelectionSets.Item("this")) Then
Set ss = ThisDrawing.SelectionSets.Item("this")
ss.Delete
End If
Set ss = ThisDrawing.SelectionSets.Add("this")
' 让用户在屏幕上选择实体
ThisDrawing.Utility.Prompt "请框选要分解的图纸部分"
ss.SelectOnScreen
'没选到图形提醒。
If ss.Count = 0 Then
MsgBox "没有选到图形！", vbExclamation
Exit Sub
End If
If Len(Dir("D:\ming\standard.dwg")) <> 0 Then
Set destDoc = ThisDrawing.Application.Documents.Open("D:\ming\standard.dwg")
Else
MsgBox "指定的文件不存在!"
End If
ReDim objCollection(ss.Count - 1) As Object
For k = 0 To ss.Count - 1
Set objCollection(k) = ss.Item(k)
Next k
acadDoc.CopyObjects objCollection, destDoc.ModelSpace
For k = 0 To ss.Count - 1
destDoc.ModelSpace.Item(k).Visible = True
Next k
' 设置缩放范围，让分出来的图Zoom-E
ThisDrawing.Application.ZoomExtents
' 保存并关闭目标文档
tPath = "D:\ming\"
destDoc.SaveAs (tPath & tName)
destDoc.Close
' 提示完成
MsgBox "所选复制完毕！"
End Sub
Public Function MtextStringClearFormat(MTextString As String) As String '清除掉多行文字中的格式。
Dim MyString As String
MyString = MTextString
MyString = ReplaceByRegExp(MyString, "\\{", Chr(1))
MyString = ReplaceByRegExp(MyString, "\\}", Chr(2))
MyString = ReplaceByRegExp(MyString, "\\\\", Chr(3))
MyString = ReplaceByRegExp(MyString, "\\S([^;]*?)(\^|#)([^;]*?);", "$1$3")
MyString = ReplaceByRegExp(MyString, "\\S([^;]*?);", "$1")
MyString = ReplaceByRegExp(MyString, "(\\P|\\O|\\o|\\L|\\l|\{|\})", "")
MyString = ReplaceByRegExp(MyString, "\\[^;]*?;", "")
MyString = ReplaceByRegExp(MyString, "\x01", "{")
MyString = ReplaceByRegExp(MyString, "\x02", "}")
MyString = ReplaceByRegExp(MyString, "\x03", "\")
MtextStringClearFormat = Trim(MyString)
End Function
Public Function ReplaceByRegExp(ByVal Mystrig As String, ByVal TxtFind As String, ByVal TxtReplace As String)'替换文字程序
Dim RE As Object
Set RE = ThisDrawing.Application.GetInterfaceObject("Vbscript.RegExp")
RE.IgnoreCase = False
RE.Global = True
RE.Pattern = TxtFind
ReplaceByRegExp = RE.Replace(Mystrig, TxtReplace)
Set RE = Nothing
End Function
块的办法，不知道为什么块不赋值。
For Each Ent In SS 'ss是选择集，Ent 是object，
' blockRef.AppendEntity Ent '赋值方法1blockRef是块
Ent.Copy blockRef '赋值方法2
Next Ent
F5运行，两种办法，Ent每次都变动，但发现blockref 都是NOthing 解决了，不是办法的办法。
把选定图形赋值给数组objCollection()的语句，放到打开新文件之前
ReDim objCollection(ss.Count - 1) As Object
For k = 0 To ss.Count - 1
Set objCollection(k) = ss.Item(k)
Next k
这样，赋值和打开文件的时间就重合了。看不出赋值时间长了。
算是不是办法的办法了。;P Ent.Copy blockRef '赋值方法2
这句得方法有误，copy方法没有参数的，不能接blockref。如果想要把图元复制到块应该是copyobject方法，参数是图形对象数组。可以网上找官网的帮助看看使用方法。 会VB，建议直接用VB.net 直接wb导出外部块不行吗 用批量打印就可以轻松实现啊
比如MSTeel（目前免费），易出图，有云批打 谢谢大家，这些代码是我在网上拼凑的，不敢说会vba.希望大家迁就下我的水平。明确下原因和改进方向。不胜感激！ 大家的意见我都会去了解下。 通过图框确定两点，再用WBLOCK保存很快， 有图框吗，有图框的话我有个插件，甚至随便画个矩形都行 batchplot，直接打印到文件，批量搞定
页:
[1]
2