[编程交流] 提取特定块

Public acad As Object
Public mspace As Object
Public excel As Object
Public AcadRunning As Integer
Public excelSheet As Object
Sub Extract()
   Dim sheet As Object
   Dim shapes As Object
   Dim elem As Object
   Dim excel As Object
   Dim Max As Integer
   Dim Min As Integer
   Dim NoOfIndices As Integer
   Dim excelSheet As Object
   Dim RowNum As Integer
   Dim Array1 As Variant
   Dim Count As Integer
    
   Set excel = GetObject(, "Excel.Application")
   Set excelSheet = excel.ActiveWorkbook.ActiveSheet
   excelSheet.Range(Cells(1, 1), Cells(45, ).Clear
   excelSheet.Range(Cells(1, 1), Cells(1, ).Font.Bold = True
   excelSheet.Range(Cells(1, 1), Cells(1, ).Font.Color = 1152
       Set acad = Nothing
   On Error Resume Next
   Set acad = GetObject(, "AutoCAD.Application")
   If Err <> 0 Then
       Set acad = CreateObject("AutoCAD.Application")
       acad.Visible = True
       MsgBox "Please open a drawing file and then restart this macro."
       Exit Sub
   End If
   Set doc = acad.ActiveDocument
   Set mspace = doc.ModelSpace
   RowNum = 1
   Dim Header As Boolean
   Header = False
   For Each elem In mspace
       With elem
           If StrComp(.EntityName, "AcDbBlockReference", 1) = 0 Then
               If .HasAttributes Then
                   Array1 = .GetAttributes
                   For Count = LBound(Array1) To UBound(Array1)
                       If Header = False Then
                           If StrComp(Array1(Count).EntityName, "AcDbAttribute", 1) = 0 Then
                               excelSheet.Cells(RowNum, Count + 1).Value = Array1(Count).TagString
                           End If
                       End If
                   Next Count
                   RowNum = RowNum + 1
                   For Count = LBound(Array1) To UBound(Array1)
                       excelSheet.Cells(RowNum, Count + 1).Value = Array1(Count).TextString
                   Next Count
                   Header = True
               End If
           End If
       End With
   Next elem
   NumberOfAttributes = RowNum - 1
   If NumberOfAttributes > 0 Then
      ActiveWorkbook.ActiveSheet.Range("A1").Sort _
       key1:=ActiveWorkbook.ActiveSheet.Columns("A"), _
       Header:=xlGuess
   Else
       MsgBox "No attributes found in the current drawing."
   End If
   Set acad = Nothing
End Sub
Private Sub Auto_Close()
   Set excelSheet = Nothing
End Sub

FilterDXFCode(0) = 0
FilterDXFVal(0) = "INSERT"
FilterDXFCode(1) = 2
FilterDXFVal(1) = "DA1DRTXT"
BLOCK_NAME = "DA1DRTXT"
Set SS = ThisDrawing.SelectionSets.Add("issued")
SS.Select acSelectionSetAll, , , FilterDXFCode, FilterDXFVal
For Cntr = 0 To SS.Count - 1
  attribs = SS.Item(Cntr).GetAttributes
attribval1 = attribs(1).TextString

    Set excelSheet = Excel.ActiveWorkbook.ActiveSheet
   With excelSheet
       .Range(.Cells(1, 1), .Cells(45, ).Clear
       .Range(.Cells(1, 1), .Cells(1, ).Font.Bold = True
       .Range(.Cells(1, 1), .Cells(1, ).Font.color = 1152
   End With

                    For Count = LBound(Array1) To UBound(Array1)
                       excelSheet.Cells(RowNum, Count + 1).Value = Array1(Count).TextString
                   Next Count

    If NumberOfAttributes > 0 Then
      excelSheet.Range("A1").Sort _
       key1:=excelSheet.Columns("A"), _
       Header:=xlGuess
   Else

                If .HasAttributes Then
                   Array1 = .GetAttributes
                   If Header = False Then
                       For Count = LBound(Array1) To UBound(Array1)
                           If StrComp(Array1(Count).EntityName, "AcDbAttribute", 1) = 0 Then
                               excelSheet.Cells(RowNum, Count + 1).Value = Array1(Count).TagString
                           End If
                       Next Count
                       Header = True
                   End If
                   RowNum = RowNum + 1
                   For Count = LBound(Array1) To UBound(Array1)
                       excelSheet.Cells(RowNum, Count + 1).Value = Array1(Count).TextString
                   Next Count
               End If