---

Hallo zusammen,
kann mir jemand sagen wie ich alle layouts nach einem bestimmten block durchsuchen kann und die Attribute dann in eine excel-Datei schreiben.
Hier mein Ansatz:
Sub Ch12_Extract()
    Dim Excel As Excel.Application
    Dim ExcelSheet As Object
    Dim ExcelWorkbook As Object
    Dim RowNum As Integer
    Dim Header As Boolean
    Dim elem As AcadEntity
    Dim Array1 As Variant
    Dim Count As Integer
    Dim Pfad As Variant
    Pfad = "R:/AutocadEinstellungen/Zeichnungskopf/ZeichnungsVerwaltung/" & ThisDrawing.ActiveLayout.name & ".xls"
    Dim Layouts As AcadLayouts, Layout As AcadLayout
    Dim msg As String
    Dim activeDoc As AcadDocument
    ' Returns current document in AutoCAD
    Set activeDoc = ThisDrawing.Application.ActiveDocument
   
 
    ' Get layouts collection from document object
    Set Layouts = ThisDrawing.Layouts
   
    For Each Layout In Layouts
        msg = msg & Layout.name & vbCrLf
    Next
   
    ' Display a list of available layouts
    MsgBox "Es befinden sich " & Layouts.Count & " Layouts in " & _
            ThisDrawing.WindowTitle & ":" & msg
   

 
    ' Excel starten.
    Set Excel = New Excel.Application
    Excel.Visible = True
  ' Erstellen einer neuen Arbeitsmappe und Suchen des aktiven Arbeitsblatts.
    Set ExcelWorkbook = Excel.Workbooks.Add
    Set ExcelSheet = Excel.ActiveSheet
   

    On Error GoTo Ende:
        ExcelWorkbook.SaveAs Pfad
       
     
     
    RowNum = 1
    Header = False
    ' Papierbereich durchlaufen, um
    ' alle Blockreferenzen zu finden.
    For Each elem In ThisDrawing.PaperSpace
            With elem
            ' Gefundene Blockreferenz auf
            ' Attribute prüfen
            If StrComp(.EntityName, "AcDbBlockReference", 1) _
                = 0 Then
                If .HasAttributes Then
                    ' Attribute abrufen
                    Array1 = .GetAttributes
                    ' Tagstrings für die Attribute
                    ' in Excel kopieren
                    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
    On Error Resume Next
            Next elem

    Excel.Application.Quit
    Set Excel = Nothing
   
    If Err.Number = 0 Then
        MsgBox "Datei wurde unter: " & Pfad & "  gespeichert"
    If Err.Number = 2 Then
        MsgBox "Abbruch durch benutzer"
    If Err.Number = 3 Then
        MsgBox "Abbruch durch benutzer"
    Else
    GoTo Ende:
     
End If

End If

End If
Ende:
End Sub

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Hallo,

erstell dir einen Auswahlsatz über alle Elemente der Zeichnung, die ein Block bestimmten Namens sind. Da werden alle Elemente, egal in welchem Layout, gefunden.
Falls es für dich wichtig ist, das Layout zu wissen oder die Blöcke nach Layout sortiert auszugeben, dann kannst du das ja dann aus den Elementeigenschaften ermitteln und entsprechend sortieren.

Grüße Holger

------------------
Holger Brischke
(defun - Lisp over night!
AutoLISP-Programmierung für AutoCAD
Da weiß man, wann man's hat!

Treffen Sie (defun auf dem Autodesk Anwendertreffen am 15.06. in Steyr/Österreich!

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Zitat:

---

Original erstellt von Brischke:
Hallo,

erstell dir einen Auswahlsatz über alle Elemente der Zeichnung, die ein Block bestimmten Namens sind. Da werden alle Elemente, egal in welchem Layout, gefunden.
Falls es für dich wichtig ist, das Layout zu wissen oder die Blöcke nach Layout sortiert auszugeben, dann kannst du das ja dann aus den Elementeigenschaften ermitteln und entsprechend sortieren.

Grüße Holger

---

Hallo Holger,
das ist genau das Problem. Wie erstelle ich den Auswahlsatz???
mit selectionset komme ich nicht klar.

Gruß Dan

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Hallo Dan,

Vielleicht hilft dir folgendes

Code:

---

Sub Test()
Dim Bloecke
Bloecke = SelAllInsertByName("TestBLK")
End Sub
Public Function SelAllInsertByName(BLKName As String)
Dim All_E
Dim i As Integer
Dim Filter(3, 1) As Variant

Filter(0, 0) = -4
Filter(0, 1) = "<AND"
Filter(1, 0) = 0 'DXF-Gruppencode
Filter(1, 1) = "Insert" 'Blöcke
Filter(2, 0) = 2 'DXF-Gruppencode
Filter(2, 1) = BLKName 'Name
Filter(3, 0) = -4
Filter(3, 1) = "AND>"

All_E = Select_All_Filter("All", Filter)
SelAllInsertByName = All_E
End Function
Public Function Select_All_Filter(awsName As String, Optional GC_VG As Variant)
Dim awss As AcadSelectionSets
Dim aws As AcadSelectionSet
Dim i As Integer
Set aws = Nothing
'<AWS löschen
Set awss = ThisDrawing.SelectionSets
For i = 0 To awss.Count - 1
  If awss(i).Name = awsName Then
    awss(i).Delete
  End If
Next i
'AWS löschen>

'<Filter umsetzen
ReDim GC(0 To UBound(GC_VG)) As Integer
ReDim GC_Value(0 To UBound(GC_VG)) As Variant
For i = 0 To UBound(GC_VG)
    GC(i) = GC_VG(i, 0)
Next i
For i = 0 To UBound(GC_VG)
    GC_Value(i) = GC_VG(i, 1)
Next i
'Filter umsetzen>

'<AWS setzen
Set aws = ThisDrawing.SelectionSets.Add(awsName)
aws.Select acSelectionSetAll, , , GC, GC_Value
'AWS setzen>
i = aws.Count - 1
If i <> -1 Then
  ReDim elems(0 To i)
  For i = 0 To aws.Count - 1
    Set elems(i) = aws.Item(i)
  Next i
End If

Select_All_Filter = elems
End Function

---

Bei Fragen ...

Grüße Holger

------------------
Holger Brischke
(defun - Lisp over night!
AutoLISP-Programmierung für AutoCAD
Da weiß man, wann man's hat!

Treffen Sie (defun auf dem Autodesk Anwendertreffen am 15.06. in Steyr/Österreich!

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Danke Holger,

wie bekomme ich den die Auswahl jetzt hierhin?:
  ' Excel starten.
    Set Excel = New Excel.Application
    Excel.Visible = True
  ' Erstellen einer neuen Arbeitsmappe und Suchen des aktiven Arbeitsblatts.
    Set ExcelWorkbook = Excel.Workbooks.Add
    Set ExcelSheet = Excel.ActiveSheet
    On Error GoTo Ende:
        ExcelWorkbook.SaveAs Pfad
    RowNum = 1
    Header = False
    ' Papierbereich durchlaufen, um
    ' alle Blockreferenzen zu finden.
    For Each elem In ThisDrawing.PaperSpace  <-- Was muss Hierhin???
            With elem
            ' Gefundene Blockreferenz auf
            ' Attribute prüfen

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Heureka,

hab herausgefunden was da hin muss!!

  ' Papierbereich durchlaufen, um
    ' alle Blockreferenzen zu finden.
    For Each elem In ThisDrawing.SelectionSets(awsName)
            With elem
            ' Gefundene Blockreferenz auf
            ' Attribute prüfen
            If StrComp(.EntityName, "AcDbBlockReference", 1) _
                = 0 Then

Danke nochmal Holger

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP