[求助]请高手帮忙调试一下

fjfhgdwfn

没看到程序啊

fjfhgdwfn

为什么我看不到啊。呵呵

要引用了下再看的到啊。

你的程序好像只能生成单张的啊。没有写循环啊。

 可以看下我的程序，写的比较乱啊

根据图中图块名存成不同的文件

Sub Example_Select_text()
   
    Dim ssetObj As AcadSelectionSet
    Dim CONUT As Integer
    CONUT = 0
    Count = ThisDrawing.SelectionSets.Count
     For I = 0 To Count - 1 '删除所有的选择集
    Set ssetObj = ThisDrawing.SelectionSets.Item(0)
      ssetObj.Delete
    Next I
  
   Dim sjx, dmx As AcadSelectionSet
 
   
   Dim FilterType(1) As Integer
   Dim FilterData(1) As Variant
   Set sjx = ThisDrawing.SelectionSets.Add("sjx")
   Set dmx = ThisDrawing.SelectionSets.Add("dmx")

   FilterType(0) = 2
   FilterData(0) = "TK" '是块名

   'FilterType(1) = 62
   'FilterData(1) = 10  '颜色是3

   FilterType(1) = 8
   FilterData(1) = "0"  '图层是0
  
   Dim mode As Integer
  Dim doc2 As AcadDocument
 Set doc2 = ThisDrawing.ModelSpace.Document
 
 mode = acSelectionSetAll
 'sjx.Select mode, , , FilterType, FilterData
  sjx.SelectOnScreen FilterType, FilterData '得到图框
    Dim newvarAttributes, inpoint, entry1 As Variant
    Dim ss, sss, ssss As String
    Dim sjxcount As Integer
    sjxcount = sjx.Count
    
     Dim templateFileName As String
   Dim DOC1 As AcadDocument
    ReDim objects(sjxcount - 1) As AcadEntity
      Dim retObjects As Variant
    Dim minExt As Variant
     Dim maxExt As Variant

  
 
     For Each ENTRY In sjx

     newvarAttributes = ENTRY.GetAttributes '得到图框块的属性，即图名图号页码
   
     ENTRY.GetBoundingBox minExt, maxExt '得到图框的最大最小坐标
     mode = acSelectionSetWindow 'acSelectionSetPrevious 'acSelectionSetCrossing
     ThisDrawing.Application.ZoomWindow minExt, maxExt
    
     dmx.Select mode, minExt, maxExt '选择图框内的对象
    
     ReDim objects(dmx.Count - 1) As AcadEntity
        I = 0
      For Each entry1 In dmx
      Set objects(I) = entry1
      I = I + 1
      Next entry1
      Set DOC1 = Documents.Add
     doc2.CopyObjects objects, DOC1.ModelSpace '拷贝对象到新文件中
     ThisDrawing.Application.ZoomWindow minExt, maxExt
   
   DOC1.SaveAs doc2.Path & "\" & newvarAttributes(1).TextString & "(" & newvarAttributes(2).TextString & ")" & newvarAttributes(0).TextString
     DOC1.Close
    
     dmx.Clear
     Next ENTRY
   

 
 
End Sub