Sub GenerateShapeCaseCode()
Dim ws As Worksheet
Dim shp As Shape
Dim newWs As Worksheet
Dim codeRow As Long
Dim codeLine As String
Dim caseNumber As Long
Set newWs = Workbooks.Add.Worksheets(1)
newWs.Name = "Generated Code"
newWs.Cells(1, 1).Value = "VBA Code für Shapes"
codeRow = 2
caseNumber = 1
Set ws = ActiveSheet
For Each shp In ws.Shapes
codeLine = "Case " & caseNumber & vbCrLf
codeLine = codeLine & " Set shp = Me.Shapes.AddShape(" & shp.AutoShapeType & ", Target.Left, Target.Top, " & _
shp.Width & ", " & shp.Height & ")" & vbCrLf
On Error Resume Next
If Not shp.Fill.Visible = msoFalse Then
codeLine = codeLine & " shp.Fill.ForeColor.RGB = " & shp.Fill.ForeColor.RGB & vbCrLf
codeLine = codeLine & " shp.Fill.BackColor.RGB = " & shp.Fill.BackColor.RGB & vbCrLf
codeLine = codeLine & " shp.Fill.Transparency = " & shp.Fill.Transparency & vbCrLf
End If
On Error GoTo 0
If shp.Line.Visible Then
codeLine = codeLine & " shp.Line.ForeColor.RGB = " & shp.Line.ForeColor.RGB & vbCrLf
codeLine = codeLine & " shp.Line.Weight = " & shp.Line.Weight & vbCrLf
codeLine = codeLine & " shp.Line.Transparency = " & shp.Line.Transparency & vbCrLf
End If
If shp.TextFrame2.TextRange.Text <> "" Then
codeLine = codeLine & " shp.TextFrame2.TextRange.Text = """ & shp.TextFrame2.TextRange.Text & """" & vbCrLf
codeLine = codeLine & " shp.TextFrame2.VerticalAnchor = " & shp.TextFrame2.VerticalAnchor & vbCrLf
codeLine = codeLine & " shp.TextFrame2.HorizontalAnchor = " & shp.TextFrame2.HorizontalAnchor & vbCrLf
codeLine = codeLine & " shp.TextFrame2.TextRange.Font.Size = " & shp.TextFrame2.TextRange.Font.Size & vbCrLf
codeLine = codeLine & " shp.TextFrame2.TextRange.Font.Name = """ & shp.TextFrame2.TextRange.Font.Name & """" & vbCrLf
End If
newWs.Cells(codeRow, 1).Value = codeLine
codeRow = codeRow + 1
caseNumber = caseNumber + 1
Next shp
MsgBox "Code wurde generiert und in eine neue Arbeitsmappe geschrieben.", vbInformation
End Sub