VBA Script erstellen - automatische Tabelle erstellen

[phs]

Hallo erstmal,

ich möchte mit Visual Basic für CorelDraw X4 ein Script erstellen,
das mir automatisch die Höhe und Breite aller meiner von Hand gesetzen Ellipsen ausgibt.
Am besten in einer Tabelle, in Excel wäre natürlich ex©ellent :sei_gepriesen:

Ich bin soweit, das wenn ich die EINE Ellipse ANKLICKE er mir meinen b,h,x,y-Wert in Corel ausgibt.

====Code=====

Sub VariablenAuslesen()
Dim OrigSelection As ShapeRange
Dim h As Double 'Hoehenvariable
Dim b As Double 'Breitenvariable
Dim x As Double 'X-Positionsvariable
Dim y As Double 'Y-Positionsvariable

Set OrigSelection = ActiveSelectionRange 'Auswahl ist markierte Auswahl
ActiveDocument.ReferencePoint = cdrCenter 'Referenzpunkt ist Mittelpunkt
OrigSelection.GetSize b, h 'Maße auslesen - Befehl:GetSize (Width As Double, Height As Double) - Variable b entspricht Widht, Variable h entspricht Height
OrigSelection.GetPosition x, y 'Position auslesen - Befehl:GetPosition( PositionX As Double, PositionY As Double)- Variable x entspricht PositionX, Variable y entspricht PositionY

Dim s1 As Shape 'Variable s1 - Variablentyp Shape
Set s1 = ActiveLayer.CreateCustomShape("Table", 8, 1, 28, 10, 5, 3)

'Zeile 1
s1.Custom.Cell(1, 1).TextShape.Text.Story = "Ellipsennummer"
s1.Custom.Cell(2, 1).TextShape.Text.Story = "x - Position"
s1.Custom.Cell(3, 1).TextShape.Text.Story = "y - Position"
s1.Custom.Cell(4, 1).TextShape.Text.Story = "Höhe"
s1.Custom.Cell(5, 1).TextShape.Text.Story = "Breite"

s1.Custom.Cell(1, 1).TextShape.Text.Story.Words.All.Size = 41
s1.Custom.Cell(2, 1).TextShape.Text.Story.Words.All.Size = 41
s1.Custom.Cell(3, 1).TextShape.Text.Story.Words.All.Size = 41
s1.Custom.Cell(4, 1).TextShape.Text.Story.Words.All.Size = 41
s1.Custom.Cell(5, 1).TextShape.Text.Story.Words.All.Size = 41

'Zeile 2
s1.Custom.Cell(1, 2).TextShape.Text.Story = "Ellipse 1"
s1.Custom.Cell(2, 2).TextShape.Text.Story = x
s1.Custom.Cell(3, 2).TextShape.Text.Story = y
s1.Custom.Cell(4, 2).TextShape.Text.Story = h
s1.Custom.Cell(5, 2).TextShape.Text.Story = b

s1.Custom.Cell(1, 2).TextShape.Text.Story.Words.All.Size = 41
s1.Custom.Cell(2, 2).TextShape.Text.Story.Words.All.Size = 41
s1.Custom.Cell(3, 2).TextShape.Text.Story.Words.All.Size = 41
s1.Custom.Cell(4, 2).TextShape.Text.Story.Words.All.Size = 41
s1.Custom.Cell(5, 2).TextShape.Text.Story.Words.All.Size = 41

End Sub

====Codeende=======

Mein Ansatz wäre jetzt das ich die ActiveSelectionRange automatisch verändern will, sodass er ALLE Ellipsen auf dem Aktiven Baltt durchläuft...aber genau da komme ich nicht weiter

Oder gibt es evtl eine einfachere Lösung?

PS:
Kenne mich mit VBA und CorelDraw leider nicht so gut aus, alles hier ist aus dem Internet zusammengesucht (Befehle), analysiert und für meine Zwecke angepasst( ausprobiert)

[koter]

Hallo phs,

...alles hier ist aus dem Internet zusammengesucht (Befehle), analysiert und für meine Zwecke angepasst( ausprobiert)

das mache ich auch oft so, man muss das Rad ja nicht immer neu erfinden.

Mein Ansatz wäre jetzt das ich die ActiveSelectionRange automatisch verändern will, sodass er ALLE Ellipsen auf dem Aktiven Baltt durchläuft...

In diesem Fall würde ich es ohne Auswahl (SelectionRange) versuchen und lieber den ShapeRange der aktiven Seite verwenden.

Hier ein Test mit X4 und Excel 2000:



Der Code:

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

Ich habe versucht die Subs und Variablen so zu benennen, dass man einigermaßen durchsteigen kann.

Vier Subs sind vielleicht ein wenig üppig, aber so lässt es sich wahrscheinlich am besten an Dein Vorhaben anpassen.

Vielleicht müssen ja noch Powerclips o. ä. berücksichtigt werden.

Willkommen im Forum!

Gruß

Koter

Nachtrag:
Excel muss laufen bevor das Makro gestartet wird!