将图纸拆分程序，求助。

jepvyg

有高手能帮忙看下吗。
为了画图方便，将所有的图都放一个文件里了。现在需要将一个个的图都独立出来，用图号命名。
忙了几天，东拼西凑做了个程序。可是运行的速度却很慢（主要是在复制阶段），还不如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

jepvyg

块的办法，不知道为什么块不赋值。
    For Each Ent In SS                     'ss是选择集，Ent 是object，
'        blockRef.AppendEntity Ent    '赋值方法1  blockRef是块
         Ent.Copy blockRef               '赋值方法2
    Next Ent
F5运行，两种办法，Ent每次都变动，但发现blockref 都是NOthing

jepvyg

解决了，不是办法的办法。
把选定图形赋值给数组objCollection()的语句，放到打开新文件之前
ReDim objCollection(ss.Count - 1) As Object
    For k = 0 To ss.Count - 1
        Set objCollection(k) = ss.Item(k)
    Next k
这样，赋值和打开文件的时间就重合了。看不出赋值时间长了。
算是不是办法的办法了。

chixun99

          Ent.Copy blockRef               '赋值方法2

这句得方法有误，copy方法没有参数的，不能接blockref。如果想要把图元复制到块应该是copyobject方法，参数是图形对象数组。可以网上找官网的帮助看看使用方法。

tiancao100

会VB，建议直接用VB.net

kucha007

直接wb导出外部块不行吗

szhorse

用批量打印就可以轻松实现啊
比如MSTeel（目前免费），易出图，有云批打

jepvyg

谢谢大家，这些代码是我在网上拼凑的，不敢说会vba.希望大家迁就下我的水平。明确下原因和改进方向。不胜感激！

jepvyg

大家的意见我都会去了解下。

m809289064j

通过图框确定两点，再用WBLOCK保存很快，

小王在学lisp

有图框吗，有图框的话我有个插件，甚至随便画个矩形都行

lengxiaxi

batchplot，直接打印到文件，批量搞定