Shape (Rechteckformen) Prozedur bleibt hängen am Sub End
13.02.2025 14:36:36
Brill, Thomas
habe ein Prüfformular erstellt. Ganz links sind Shapes (Rechteckformen) die beim klicken einen anderen Text bekommen.
das funktioniert auch schon einigermaßen.
Beim schnellen klicken mehrerer Shapes hintereinander bleibt die Prozedur im Modul modShapeKlick mit einem Fehler
am End Sub hinter dem Befehl SendKeys "{Esc}"stehen.
Gelegentlich werden auch mehrere Shapes beim klicken Fokussiert.
Die Prozedur click_Shape habe ich mir mit den Infos von aufgezeichneten Makros erstellt.
Ist mit Sicherheit ein genereller Fehler in der Prozedur selbst.
Beispieldatei ist hier zu finden:
https://www.herber.de/bbs/user/175654.xlsm
Sub click_Shape()
Dim objShp As Shape
Set objShp = ActiveSheet.Shapes(Application.Caller)
Application.ScreenUpdating = False
With objShp
.Select
If objShp.TextFrame2.TextRange.Characters.Text = "O" Then
objShp.TextFrame2.TextRange.Characters.Text = "ü"
With objShp.TextFrame2.TextRange.Characters(1, 1).Font
.Size = 12
.Name = "Wingdings"
End With
With Selection.ShapeRange.Fill
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorAccent6
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = 0.8000000119
.Transparency = 0
.Solid
End With
ElseIf objShp.TextFrame2.TextRange.Characters.Text = "ü" Then
objShp.TextFrame2.TextRange.Characters.Text = "Ï"
With objShp.TextFrame2.TextRange.Characters(1, 1).Font
.Size = 12
.Name = "Wingdings 2"
End With
With Selection.ShapeRange.Fill
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorAccent5
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = 0.8000000119
.Transparency = 0
.Solid
End With
ElseIf objShp.TextFrame2.TextRange.Characters.Text = "Ï" Then
objShp.TextFrame2.TextRange.Characters.Text = "O"
With objShp.TextFrame2.TextRange.Characters(1, 1).Font
.Size = 10
.Name = "Arial"
End With
With Selection.ShapeRange.Fill
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorBackground1
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = -0.0500000007
.Transparency = 0
.Solid
End With
ElseIf objShp.TextFrame2.TextRange.Characters.Text = "" Then
objShp.TextFrame2.TextRange.Characters.Text = "O"
With objShp.TextFrame2.TextRange.Characters(1, 1). _
ParagraphFormat
.FirstLineIndent = 0
.Alignment = msoAlignCenter
End With
With objShp.TextFrame2.TextRange.Characters(1, 1).Font
.NameComplexScript = "+mn-cs"
.NameFarEast = "+mn-ea"
With objShp.TextFrame2.TextRange.Characters(1, 1).Font.Fill
.Visible = msoTrue
.ForeColor.RGB = RGB(0, 0, 0)
.Transparency = 0
.Solid
End With
.Size = 10
.Name = "Arial"
End With
With Selection.ShapeRange.Fill
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorBackground1
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = -0.0500000007
.Transparency = 0
.Solid
End With
End If
End With
Set objShp = Nothing
Application.ScreenUpdating = True
SendKeys "{Esc}"
End SubWer kann mir einen Tipp geben woran der Fehler liegen könnte.
Vielen Dank im Voraus
Thomas
Anzeige