VBA Script erstellen - automatische Tabelle erstellen

Code:
Type Ellipsendaten

    Höhe As Double

    Breite As Double

    X As Double

    Y As Double

End Type

Dim Ellipsenzähler

Dim Ellipsenfeld() As Ellipsendaten



Sub eStart()

    ActiveDocument.Unit = cdrMillimeter 'die Maßeinheit des Dokuments einstellen

    Ellipsenzähler = 0

    Call EllipsenSuchen(ActivePage.Shapes.All)

    Call TabelleErstellen

    Debug.Print "Ende"

End Sub



Sub EllipsenSuchen(sr As ShapeRange)

    Dim s As Shape

    For Each s In sr

        Select Case s.Type

        Case cdrEllipseShape ' ist das Objekt eine Ellipse werden die Daten angelegt.

            Call DatenAnlegen(s)

        Case cdrGroupShape ' ist das Objekt eine Gruppe ruft sich die Sub selbst auf (Rekursion)

            Call EllipsenSuchen(s.Shapes.All)

        End Select

    Next

End Sub



Sub DatenAnlegen(s As Shape)

    ReDim Preserve Ellipsenfeld(Ellipsenzähler)

    

    s.GetSize _

        Ellipsenfeld(Ellipsenzähler).Breite, _

        Ellipsenfeld(Ellipsenzähler).Höhe

    s.GetPosition _

        Ellipsenfeld(Ellipsenzähler).X, _

        Ellipsenfeld(Ellipsenzähler).Y

        

    Ellipsenzähler = Ellipsenzähler + 1

End Sub



Private Sub TabelleErstellen()

    On Error GoTo Fehler 'Falls Excel nicht läuft, oder Keine Tabelle geöffnet ist, oder, oder...

    Dim XL As Object

    Set XL = GetObject(, "Excel.Application") 'Kontakt mit Excel aufnehmen

    Frage = MsgBox("Aktuelle Tabelle überschreiben?", vbYesNo + vbQuestion, "Excel")

    If Frage <> vbYes Then Exit Sub

    With XL.ActiveSheet ' Spaltenüberschriften setzen

        .Cells.Delete Shift:=xlUp ' Alle Zellen löschen

        .Cells(1, 1) = "Ellipsennummer"

        .Cells(1, 2) = "x - Position"

        .Cells(1, 3) = "y - Position"

        .Cells(1, 4) = "Höhe"

        .Cells(1, 5) = "Breite"

    End With

    With XL.ActiveSheet ' Daten Eintragen

        For i = 0 To Ellipsenzähler - 1

        .Cells(i + 2, 1) = i + 1

        .Cells(i + 2, 2) = Ellipsenfeld(i).X

        .Cells(i + 2, 3) = Ellipsenfeld(i).Y

        .Cells(i + 2, 4) = Ellipsenfeld(i).Höhe

        .Cells(i + 2, 5) = Ellipsenfeld(i).Breite

        Next i

        .Columns("A:E").EntireColumn.AutoFit  ' Spaltenbreite automatisch

        .Columns("B:E").NumberFormat = "0.00" ' Zahlenformat bestimmen

        .Rows("1:1").Font.FontStyle = "Bold"  ' Erste Zeile Fett

    End With



    Set XL = Nothing

    Exit Sub

Fehler: ' Fehlerbehandlung (Ausbaufähig)

    MsgBox "Irgendwas stimmt nicht!", vbCritical, "Fehler"

End Sub