Laufzeitfehler b. Erzeugung "fast" gleicher Shapes
04.07.2018 15:19:08
Holger
Private Sub Workbook_Open()
Worksheets("TableEx").Select
'****************************BUTTONs löschen wenn vorhanden******************************
Dim Form
For Each Form In ActiveSheet.Shapes
If Form.Name = "QImport" Then
ActiveSheet.Shapes("QImport").Delete
End If
If Form.Name = "KImport" Then
ActiveSheet.Shapes("KImport").Delete
End If
If Form.Name = "KHolen" Then
ActiveSheet.Shapes("KHolen").Delete
End If
If Form.Name = "NeueBeziehung" Then
ActiveSheet.Shapes("NeueBeziehung").Delete
End If
If Form.Name = "NeuesKriterium" Then
ActiveSheet.Shapes("NeuesKriterium").Delete
End If
If Form.Name = "KriteriumLoeschen" Then
ActiveSheet.Shapes("KriteriumLoeschen").Delete
End If
Next
'****************************BUTTON Quelle importieren******************************
ActiveSheet.Shapes.AddShape(msoShapeRectangle, 453, 192, 136.5, 13.5).Select
With Selection.ShapeRange(1)
.Name = "QImport"
.OnAction = "QuelldateiLaden"
End With
Selection.ShapeRange.ShapeStyle = msoShapeStylePreset36
Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = "Quelle importieren"
Selection.ShapeRange.ScaleHeight 1.2777777778, msoFalse, msoScaleFromBottomRight
Selection.ShapeRange.ScaleHeight 1.1739130435, msoFalse, msoScaleFromTopLeft
Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 18).ParagraphFormat. _
FirstLineIndent = 0
Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 18).ParagraphFormat.Alignment = _
msoAlignLeft
With Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 18).Font
.NameComplexScript = "+mn-cs"
.NameFarEast = "+mn-ea"
.Fill.Visible = msoTrue
.Fill.ForeColor.ObjectThemeColor = msoThemeColorLight1
.Fill.ForeColor.TintAndShade = 0
.Fill.ForeColor.Brightness = 0
.Fill.Transparency = 0
.Fill.Solid
.Size = 11
.Name = "+mn-lt"
End With
'****************************BUTTON Kriterien importieren******************************
ActiveSheet.Shapes.AddShape(msoShapeRectangle, 453, 300, 136.5, 13.5).Select
With Selection.ShapeRange(1)
.Name = "KImport"
.OnAction = "KriteriendateiLaden"
End With
Selection.ShapeRange.ShapeStyle = msoShapeStylePreset36
Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = "Kriterien importieren"
Selection.ShapeRange.ScaleHeight 1.2777777778, msoFalse, msoScaleFromBottomRight
Selection.ShapeRange.ScaleHeight 1.1739130435, msoFalse, msoScaleFromTopLeft
Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 18).ParagraphFormat. _
FirstLineIndent = 0
Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 18).ParagraphFormat.Alignment = _
msoAlignLeft
With Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 18).Font
.NameComplexScript = "+mn-cs"
.NameFarEast = "+mn-ea"
.Fill.Visible = msoTrue
.Fill.ForeColor.ObjectThemeColor = msoThemeColorLight1
.Fill.ForeColor.TintAndShade = 0
.Fill.ForeColor.Brightness = 0
.Fill.Transparency = 0
.Fill.Solid
.Size = 11
.Name = "+mn-lt"
End With
'****************************BUTTON Kriterien konfigurieren******************************
ActiveSheet.Shapes.AddShape(msoShapeRectangle, 453, 472, 136.5, 13.5).Select
With Selection.ShapeRange(1)
.Name = "KHolen"
.OnAction = "KriterienHolen"
End With
Selection.ShapeRange.ShapeStyle = msoShapeStylePreset36
Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = "Kriterien konfigurieren"
Selection.ShapeRange.ScaleHeight 1.2777777778, msoFalse, msoScaleFromBottomRight
Selection.ShapeRange.ScaleHeight 1.1739130435, msoFalse, msoScaleFromTopLeft
Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 18).ParagraphFormat. _
FirstLineIndent = 0
Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 18).ParagraphFormat.Alignment = _
msoAlignLeft
With Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 18).Font
.NameComplexScript = "+mn-cs"
.NameFarEast = "+mn-ea"
.Fill.Visible = msoTrue
.Fill.ForeColor.ObjectThemeColor = msoThemeColorLight1
.Fill.ForeColor.TintAndShade = 0
.Fill.ForeColor.Brightness = 0
.Fill.Transparency = 0
.Fill.Solid
.Size = 11
.Name = "+mn-lt"
End With
'****************************BUTTON Kriterien verknüfen******************************
ActiveSheet.Shapes.AddShape(msoShapeRectangle, 453, 512, 136.5, 13.5).Select
With Selection.ShapeRange(1)
.Name = "NeueBeziehung"
.OnAction = "KriterienVerknuepfen"
End With
Selection.ShapeRange.ShapeStyle = msoShapeStylePreset36
Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = "Kriterien verknüpfen"
Selection.ShapeRange.ScaleHeight 1.2777777778, msoFalse, msoScaleFromBottomRight
Selection.ShapeRange.ScaleHeight 1.1739130435, msoFalse, msoScaleFromTopLeft
Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 18).ParagraphFormat. _
FirstLineIndent = 0
Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 18).ParagraphFormat.Alignment = _
msoAlignLeft
With Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 18).Font
.NameComplexScript = "+mn-cs"
.NameFarEast = "+mn-ea"
.Fill.Visible = msoTrue
.Fill.ForeColor.ObjectThemeColor = msoThemeColorLight1
.Fill.ForeColor.TintAndShade = 0
.Fill.ForeColor.Brightness = 0
.Fill.Transparency = 0
.Fill.Solid
.Size = 11
.Name = "+mn-lt"
End With
'****************************BUTTON Neues Kriterium******************************
ActiveSheet.Shapes.AddShape(msoShapeRectangle, 453, 542, 136.5, 13.5).Select
With Selection.ShapeRange(1)
.Name = "NeuesKriterium"
.OnAction = "KritNeu"
End With
Selection.ShapeRange.ShapeStyle = msoShapeStylePreset36
Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = "Neues Kriterium"
Selection.ShapeRange.ScaleHeight 1.2777777778, msoFalse, msoScaleFromBottomRight
Selection.ShapeRange.ScaleHeight 1.1739130435, msoFalse, msoScaleFromTopLeft
Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 18).ParagraphFormat. _
FirstLineIndent = 0
Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 18).ParagraphFormat.Alignment = _
msoAlignLeft
With Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 18).Font
.NameComplexScript = "+mn-cs"
.NameFarEast = "+mn-ea"
.Fill.Visible = msoTrue
.Fill.ForeColor.ObjectThemeColor = msoThemeColorLight1
.Fill.ForeColor.TintAndShade = 0
.Fill.ForeColor.Brightness = 0
.Fill.Transparency = 0
.Fill.Solid
.Size = 11
.Name = "+mn-lt"
End With
'****************************BUTTON Kriterium löschen******************************
ActiveSheet.Shapes.AddShape(msoShapeRectangle, 453, 542, 136.5, 13.5).Select
With Selection.ShapeRange(1)
.Name = "KriteriumLoeschen"
.OnAction = "KritLoeschen"
End With
Selection.ShapeRange.ShapeStyle = msoShapeStylePreset36
Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = "Letztes Löschen"
Selection.ShapeRange.ScaleHeight 1.2777777778, msoFalse, msoScaleFromBottomRight
Selection.ShapeRange.ScaleHeight 1.1739130435, msoFalse, msoScaleFromTopLeft
Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 18).ParagraphFormat. _
FirstLineIndent = 0
Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 18).ParagraphFormat.Alignment = _
msoAlignLeft
With Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 18).Font
.NameComplexScript = "+mn-cs"
.NameFarEast = "+mn-ea"
.Fill.Visible = msoTrue
.Fill.ForeColor.ObjectThemeColor = msoThemeColorLight1
.Fill.ForeColor.TintAndShade = 0
.Fill.ForeColor.Brightness = 0
.Fill.Transparency = 0
.Fill.Solid
.Size = 11
.Name = "+mn-lt"
End With
End Sub
Es sollen Shapes erzeugt werden, denen ein Name und ein Makro zugewiesen wird.
Das klappt für die ersten paar Buttons auch. Doch beim Button "BUTTON Neues Kriterium" bricht das Ganze mit Laufzeitfehler 5 ab (Ungültiger Prozeduraufruf oder ungültiges Argument)
Die Buttons unterscheiden sich nur bei ihrem .Name, .OnAction und beim Text in der TextBox des Shapes.
Beim einzelnen Durchlaufen der Zeilen bricht das Programm bei o.g. Button bei der Zeile
Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 18).ParagraphFormat.FirstLineIndent = 0
ab.
Kommentiere ich die Zeile aus, passiert das gleiche mit der nächsten Zeile.
Ich übersehe garantiert was. Ich schnell nur nicht was.
Die zugehärigen .onAction Makros liegen alle im Modul 1. Ich habe deren Namen alle via CopyPaste kopiert, um Tippfehler auszuschließen.
Ich würde mich sehr freuen, wenn jemand helfen kann.