[编程交流] 从mul导出属性数据

Public Sub TelAllDocs()
Dim aDocs As Variant, aDoc As AcadDocument
Dim oBlok As AcadBlockReference, Pt
Dim Excel As Object, ExcelSheet As Object
Dim nX
Dim EersteRij() As Variant
   Debug.Print
   
   Set Excel = StartExcel
   Excel.Visible = True
   Excel.Workbooks.Add
   Set ExcelSheet = Excel.sheets.Add
   ExcelSheet.name = Format(Application.Documents.Count, "00") & "-documenten"
   RowNum = 2
   
   EersteRij = Array("Bloknaam", "X", "Y", "Handle", "Layer", "Pad", "Filenaam")
   
   ExcelSheet.Range("A1:BZ1").Font.Bold = True
   For nX = LBound(EersteRij) To UBound(EersteRij)
       ExcelSheet.cells(1, nX + 1).Value = EersteRij(nX)
   Next nX
   
   AppActivate "Autocad", False
   DoEvents
   On Error Resume Next
   ThisDrawing.Utility.GetEntity oBlok, Pt, "Wijs Blok aan : "
   If Err.Number <> 0 Then Exit Sub
   On Error GoTo 0
   
   Set aDocs = Application.Documents
   
   For Each aDoc In aDocs
       Debug.Print aDoc.Path; ""; aDoc.name
       aDoc.Activate
       TelAttrDoc oBlok.name
   Next
   Beep
   Set Excel = Nothing
   Set ExcelSheet = Nothing
   
End Sub
Private Sub TelAttrDoc(sBlokNaam)
Dim Excel As Object
Dim oBlokje As Object
Dim ExcelSheet As Object
Dim Array1 As Variant
Dim Count
Dim NumberOfAttributes As Integer
Dim FoundAttributes As Boolean
Dim tmp As Integer
Dim oBlokjeReference As AcadBlockReference
Dim sBlokName As String
Dim nKol1, nX, Retval As Double, nTimeout As Byte
Dim EersteRij() As Variant
Dim W9 As AcadSelectionSet
Dim Q4 As cObj
   Set Q4 = New cObj
   Q4.VoegToeGroepModified BLOK, Left(sBlokNaam, 7) & "*"
   Q4.SelType = acSelectAll
   Q4.ExcecuteSelect
   
   Set W9 = ThisDrawing.SelectionSets(Q4.SelSetNaam)
   Debug.Print W9.Count
   If W9.Count = 0 Then Exit Sub
   
   nTagTeller = 0
   Set Excel = StartExcel
   Set ExcelSheet = Excel.sheets(Format(Application.Documents.Count, "00") & "-documenten")
   
   On Error GoTo 0
   EersteRij = Array("", "", "", "", "", "", "")
   
   For Each oBlokje In W9
       If oBlokje.HasAttributes Then
           Set oBlokjeReference = oBlokje
               ExcelSheet.cells(RowNum, 1) = oBlokje.name
               ExcelSheet.cells(RowNum, 1).NumberFormat = "@"
               ExcelSheet.cells(RowNum, 2).Value = oBlokjeReference.InsertionPoint(0)
               ExcelSheet.cells(RowNum, 3).Value = oBlokjeReference.InsertionPoint(1)
               ExcelSheet.cells(RowNum, 4).NumberFormat = "@"
               ExcelSheet.cells(RowNum, 4).Value = oBlokjeReference.Handle
               ExcelSheet.cells(RowNum, 5).Value = oBlokjeReference.Layer
               ExcelSheet.cells(RowNum, 6).Value = ThisDrawing.GetVariable("dwgprefix")
               ExcelSheet.cells(RowNum, 7).Value = ThisDrawing.GetVariable("dwgname")
               Array1 = oBlokjeReference.GetAttributes
               For Count = LBound(Array1) To UBound(Array1)
                   nKol1 = WelkeKolomMod(Trim(Array1(Count).TagString), ExcelSheet, UBound(EersteRij) + 1)
                   ExcelSheet.cells(RowNum, nKol1).NumberFormat = "@"
                   ExcelSheet.cells(RowNum, nKol1).Value = Trim(Array1(Count).TextString)
               Next Count
               RowNum = RowNum + 1
       End If
   Next oBlokje
   Set Excel = Nothing
   Set ExcelSheet = Nothing
End Sub