Excel vba Properties von Shapes & Commandbutton

[sharky51]

Hallo zusammen,

könntet Ihr mir wieder mal bei einer Aufgabe helfen?

Ich möchte aus allen Tabellenblättern von jeweils allen platzierten Shapes und Commandbuttons  sämtliche Properties auslesen und in ein neu eingefügtes Tabellenblatt schreiben.
Also etwa in der Form:


ShapePropertiesAll

	A	B	C	D	E	F	G	H	I
1	Shape Name	Shape Type	Height	Width	Left	Top	MarginLeft	MarginRight	Sheet Name
2	Rechtwinkliges Dreieck 1	Rechtwinkliges Dreieck 1	50	50	25	10	2,83464574813843	2,83464574813843	Contents
3	Rounded Rectangle 1_ContentButton	Rounded Rectangle 1_ContentButton	20	60	200	4	7,19999980926514	7,19999980926514	Test
4	Rounded Rectangle 1_ContentButton	Rounded Rectangle 1_ContentButton	20	60	200	4	7,19999980926514	7,19999980926514	Rechnung
5	Rounded Rectangle 1_ContentButton	Rounded Rectangle 1_ContentButton	20	60	200	4	7,19999980926514	7,19999980926514	Erich
6	Rounded Rectangle 1_ContentButton	Rounded Rectangle 1_ContentButton	20	60	200	4	7,19999980926514	7,19999980926514	Global
7	Rounded Rectangle 1_ContentButton	Rounded Rectangle 1_ContentButton	20	60	200	4	7,19999980926514	7,19999980926514	Tabelle5
8	Rounded Rectangle 1_ContentButton	Rounded Rectangle 1_ContentButton	20	60	200	4	7,19999980926514	7,19999980926514	Hans
9	Rounded Rectangle 1_ContentButton	Rounded Rectangle 1_ContentButton	20	60	200	4	7,19999980926514	7,19999980926514	Tabelle9
10	CommandButton1	CommandButton1	38,25	169,5	60	38,25

Füllfarben und Muster
Zelle	Rot	Grün	Blau	Color	Muster	Farbe
A1:I1	255	255	0	65535

Zellen mit Füllfarbe automatisch werden nicht dargestellt

Code:

  'Add headings for our lists. Expand as needed
  WsNew.Range("A1:I1") = Array("Shape Name", "Shape Type", "Height", "Width", "Left", "Top", "MarginLeft", "MarginRight", "Sheet Name")
  'Loop through all Worksheet
  For Each wsLoop In Worksheets
      'Loop through all shapes on Worksheet
      For Each sShapes In wsLoop.Shapes
        'Increment Variable lLoop for row numbers[img]file:///I:/User/Downloads/Unbenannt.JPG.html[/img]
        lLoop = lLoop + 1
        With sShapes
            'Add shape properties
            WsNew.Cells(lLoop + 1, 1) = .Name
            WsNew.Cells(lLoop + 1, 2) = .OLEFormat.Object.Name
            WsNew.Cells(lLoop + 1, 3) = .Height
            WsNew.Cells(lLoop + 1, 4) = .Width
            WsNew.Cells(lLoop + 1, 5) = .Left
            WsNew.Cells(lLoop + 1, 6) = .Top
            'Follow the same pattern for more
            WsNew.Cells(lLoop + 1, 7) = .TextFrame2.MarginLeft
            WsNew.Cells(lLoop + 1, 8) = .TextFrame2.MarginRight
            WsNew.Cells(lLoop + 1, 9) = wsLoop.Name
        End With
      Next sShapes
  Next wsLoop
  'AutoFit Columns.
  WsNew.Columns.AutoFit

Wenn jetzt ein Commandbutton behandelt wird, werden zwar die Koordinaten ausgelesen aber dann kommt bei "TextFrame2.MarginLeft" usw. natürlich eine Fehlermeldung.
Bei Shapes funktioniert das aber hier nicht.

Wie kann ich a) den Fehler umgehen und b) auslesen welcher Text auf dem Button steht?
Schön wäre auch den Text von den allen Shapes auszulesen zu können.

Habt Ihr mir da ev. einen Lösungsvorschlag?

[snb]

Hast du da eine Beispieldatei?

[sharky51]

Hallo,

kuckst Du hier die Beispieldatei.

[00202]

Hallo Erich, :19:

hier mal deine Beispieldatei zurück: :21:
[attachment=29008]

[sharky51]

Guten morgen Case,

das ist ja cool!

Herzlichen Dank für Deine Mühe!

Jetzt habe ich nur noch eine Frage.
Wie kann ich z.B. die "Rounded Rectangle 10_ContentButton" abhängig von der letzten Spalte, in der irgend etwas Beliebiges in einer Zeile steht, automatisch in der nächstfolgenden Spalte in Zeile "eins" platzieren? So wie z.B. auf der Tabelle "ShapePropertiesAll" zu sehen ist.

Das soll für alle Blätter gelten und die Shapes sollen natürlich in jedem Blatt automatisch platziert werden.

Ich hoffe ich habe das nicht zu umständlich beschrieben?

[00202]

Hallo Erich, :19:

hier was zum spielen, damit du siehst, wie man Shapes positionieren kann. :21:
[attachment=29011]

[sharky51]

Case,

Mann-o-Mann, das ist ja so was von super!

Vielen Dank! Du, Ihr seid die Besten!!!!!

Wünsche noch einen schönen Sonntag.

[snb]

Es geht einfach so:


Es geht einfach so:

PHP-Code:

Sub M_snb()
  ReDim sn(1000, 8)
    
  For Each it In Sheets
    For Each it1 In it.Shapes
      sn(y, 0) = it1.Name
      sn(y, 1) = it1.OLEFormat.Object.Name
      sn(y, 2) = it1.Height
      sn(y, 3) = it1.Width
      sn(y, 4) = it1.Left
      sn(y, 5) = it1.Top
      sn(y, 6) = it1.TextFrame.MarginLeft
      sn(y, 7) = it1.TextFrame.MarginRight
      sn(y, 8) = it.Name
      y = y + 1
    Next
  Next
    
  Tabelle22.Cells(20, 1).Resize(UBound(sn), 9) = sn
End Sub 


[sharky51]

Hallo Case,

Nochmals cool.....das Ganze!

Aber ich habe mal ein wenig herumgespielt.
Wenn ich mehrere Shapes auf einem Blatt habe entsteht etwas Verwirrung.

Als Test habe ich mal diese drei Teile auf ein Blatt eingefügt
Button 1
Herz 1
Rechtwinkliges Dreieck 1

Mit Deinem Code schnappt sich dieser nur den Button 1 und läßt die andern beiden unbehelligt. Warum ausgerechnet den Button 1? Ich nehme an wegen der Bezeichnung, B kommt vor H usw.!
Wie kann man denn alle drei Shapes platzieren, am besten nebeneinander mit ein wenig Abstand, oder mit Angabe einer zusätzlichen Spaltenposition oder einem Offset.

Das erste Shape wird ja in die nächste freie Spalte platziert.

Code:

Sub Main2()
    Dim wksSheet As Worksheet
    For Each wksSheet In ThisWorkbook.Worksheets
        With wksSheet
            .Shapes(1).Top = .Cells(1, .Cells(1, .Columns.Count).End(xlToLeft).Column + 1).Top
            .Shapes(1).Left = .Cells(1, .Cells(1, .Columns.Count).End(xlToLeft).Column + 1).Left
        End With
    Next wksSheet
End Sub

[00202]

Hallo Erich, :19:

nochmal was zum spielen: :21:
[attachment=29024]