WordArt search error

[WhoCanDo]

I'm having problems retrieving text from WordArt when it doesn't exist - sometimes

Please use this macro to set yourself up ..

Sub KPTB1_S()
    Set ActiveShape = ActiveSheet.Shapes.AddTextEffect(msoTextEffect31, "1", "Arial", 8, msoFalse, msoFalse, 50, 50)
    ActiveShape.Name = "LTST"
    Set ActiveShape = ActiveSheet.Shapes.AddTextEffect(msoTextEffect31, "2", "Arial", 8, msoFalse, msoFalse, 50, 100)
    ActiveShape.Name = "LBST"
    Set ActiveShape = ActiveSheet.Shapes.AddTextEffect(msoTextEffect31, "3", "Arial", 8, msoFalse, msoFalse, 50, 150)
    ActiveShape.Name = "RTST"
    Set ActiveShape = ActiveSheet.Shapes.AddTextEffect(msoTextEffect31, "4", "Arial", 8, msoFalse, msoFalse, 50, 200)
    ActiveShape.Name = "RBST"
End Sub

The above will place the WordArt numbers 1 to 4 on an Excel sheet. The following code should find each of those WordArts and make w=1, x=2, y=3 & z=4

Sub Get_Text()
    On Error GoTo 1
    Set ActiveShape = ActiveSheet.Shapes("LTST")
    If (ActiveShape.TextEffect.Text <> "SNIPE SIZE") And (ActiveShape.TextEffect.Text <> "") Then w = ActiveShape.TextEffect.Text
1   On Error GoTo 2
    Set ActiveShape = ActiveSheet.Shapes("LBST")
    If (ActiveShape.TextEffect.Text <> "SNIPE SIZE") And (ActiveShape.TextEffect.Text <> "") Then x = ActiveShape.TextEffect.Text
2   On Error GoTo 3
    Set ActiveShape = ActiveSheet.Shapes("RTST")
    If (ActiveShape.TextEffect.Text <> "SNIPE SIZE") And (ActiveShape.TextEffect.Text <> "") Then y = ActiveShape.TextEffect.Text
3   On Error GoTo 4
    Set ActiveShape = ActiveSheet.Shapes("RBST")
    If (ActiveShape.TextEffect.Text <> "SNIPE SIZE") And (ActiveShape.TextEffect.Text <> "") Then Z = ActiveShape.TextEffect.Text
4   On Error GoTo 0
    MsgBox (w & " " & x & " " & y & " " & Z)
End Sub

This works well when any one WordArt is deleted but not when two or more are deleted.

It seems like the On Error's aren't working properly.

Anyone got an idea to make this work with any two or all of them deleted?

 

[WhoCanDo]

 

[WhoCanDo]

For anyone interested this is my work-around until I can find how to test for the existence of a WordArt object.

Sub Get_Text()
    On Error Resume Next
    Set ActiveShape = ActiveSheet.Shapes("LTST")
    If (ActiveShape.TextEffect.Text <> "SNIPE SIZE") And (ActiveShape.TextEffect.Text <> "") And (InStr(1, ActiveShape.Name, "LTST") > 0) Then w = ActiveShape.TextEffect.Text
    Set ActiveShape = ActiveSheet.Shapes("LBST")
    If (ActiveShape.TextEffect.Text <> "SNIPE SIZE") And (ActiveShape.TextEffect.Text <> "") And (InStr(1, ActiveShape.Name, "LBST") > 0) Then x = ActiveShape.TextEffect.Text
    Set ActiveShape = ActiveSheet.Shapes("RTST")
    If (ActiveShape.TextEffect.Text <> "SNIPE SIZE") And (ActiveShape.TextEffect.Text <> "") And (InStr(1, ActiveShape.Name, "RTST") > 0) Then y = ActiveShape.TextEffect.Text
    Set ActiveShape = ActiveSheet.Shapes("RBST")
    If (ActiveShape.TextEffect.Text <> "SNIPE SIZE") And (ActiveShape.TextEffect.Text <> "") And (InStr(1, ActiveShape.Name, "RBST") > 0) Then Z = ActiveShape.TextEffect.Text
    On Error GoTo 0
    MsgBox (w & " " & x & " " & y & " " & Z)
End Sub

I have changed the "On Error Goto" to "On Error Resume Next" and I am testing for "InStr(1, ActiveShape.Name, "RTST") > 0" before running the associated code.

I would still be happier if I could test for "if ActiveShape exists" rather than "if it contains the correct information" though.

 

[WhoCanDo]

Ok, found it. For anyone else interested ..

On Error Resume Next
ActiveShapeID = ActiveSheet.Shapes("LTST").ID
If IsEmpty(ActiveShapeID) Then KPCB1 = False Else KPCB1 = True
On Error GoTo 0