0

This code allows you to add 2 shapes "oval" to a selected cell range and rename the shapes.

It uses 3 InputBoxes:

  • "1/3 Select Shape Range"
  • "2/3 Enter Shape Name shp1"
  • "3/3 Enter Shape Name shp2"

How do you build the "Enter Shape Name"-InputBox to ensure a unique name is given to every shape and have a MsgBox saying "This name is already taken"?

Option Explicit

'========================================================================
' InputBox: Add Shapes for Buttons v3
'========================================================================
' Buttons: 2
' Cell Size: Width 47
' Button Size: DIA
' Line Weight: LWT
' Shape Type: msoShapeOval, No 9
'========================================================================

Sub IPB_AddShapes_Buttons_v3()

Dim ws As Worksheet

Dim rng As Range
Dim shp1 As Shape
Dim shp2 As Shape

Const DIA As Single = 9
Const LWT As Single = 1

On Error Resume Next

Set ws = ActiveSheet

Set rng = Application.InputBox(Title:="1/3 Select Shape Range", _
                               Prompt:="", _
                               Type:=8)

  Set shp1 = ws.Shapes.AddShape(9, _
                                rng.Left + 5, _
                                rng.Top + ((rng.Height - DIA) / 2), _
                                DIA, _
                                DIA)
    With shp1
        .Name = Application.InputBox(Title:="2/3 Enter Name Level 1", _
                                     Default:="Click L1 ", _
                                     Prompt:="", _
                                     Type:=2)
        .Shadow.Visible = False
        .Fill.Visible = True
        .Fill.ForeColor.RGB = vbGreen
        .Line.Visible = False
        .Line.ForeColor.RGB = vbGreen
        .Line.Weight = LWT
        .Line.Transparency = 0
    End With
    
  Set shp2 = ws.Shapes.AddShape(9, _
                                rng.Left + 19, _
                                rng.Top + ((rng.Height - DIA) / 2), _
                                DIA, _
                                DIA)
    With shp2
        .Name = Application.InputBox(Title:="3/3 Enter Name Level 2", _
                                     Default:="Click L2 ", _
                                     Prompt:="", _
                                     Type:=2)
        .Shadow.Visible = False
        .Fill.Visible = True
        .Fill.ForeColor.RGB = vbGreen
        .Line.Visible = False
        .Line.ForeColor.RGB = vbGreen
        .Line.Weight = LWT
        .Line.Transparency = 0
    End With  
    
  MsgBox "Shape Names:" & vbNewLine & vbNewLine & _
               "" & shp1.Name & vbNewLine & _
               "" & shp2.Name, , ""
    
End Sub
'========================================================================

EDIT

@taller presents two solutions.

This is the first solution, using:

  • "Add an UDF to validate user's input."
  • "Another option UDF"

The user has one retry to name the shapes with a unique name. Two message boxes inform the user. MsgBox 1: if the name entered is a duplicate, the user is asked to retry. MsgBox 2: if the retry failed, the user is asked to restart. Everything works perfectly.

Option Explicit

'========================================================================
' InputBox: Add Shapes for Buttons v3 UPDATE v0
'========================================================================
' Buttons: 2
' Cell Size: Width 47
' Button Size: DIA
' Line Weight: LWT
' Shape Type: msoShapeOval, No 9
'========================================================================

Sub IPB_AddShapes_Buttons_000_v3_UPDATE_v0()

Dim ws As Worksheet

Dim rng As Range
Dim shp1 As Shape
Dim shp2 As Shape

Const DIA As Single = 9
Const LWT As Single = 1

On Error Resume Next

Set ws = ActiveSheet

Set rng = Application.InputBox(Title:="1/3 Select Shape Range", _
                               Prompt:="", _
                               Type:=8)

  Set shp1 = ws.Shapes.AddShape(9, _
                                rng.Left + 5, _
                                rng.Top + ((rng.Height - DIA) / 2), _
                                DIA, _
                                DIA)
    With shp1
        Dim sName As String
        sName = Application.InputBox(Title:="2/3 Enter Name Level 1", _
                                     Default:="Click L1 ", _
                                     Prompt:="", _
                                     Type:=2)
        If Not ValidateName(sName) Then
            MsgBox "Shape name [" & sName & "] is duplicated."  _
            & vbCrLf & "Please try again.", vbExclamation, "Duplicate"
            sName = Application.InputBox(Title:="2/3 Enter Name Level 1", _
                                         Default:="Click L1 ", _
                                         Prompt:="", _
                                         Type:=2)
        End If
        If ValidateName(sName) Then
            .Name = sName
            .Shadow.Visible = False
            .Fill.Visible = True
            .Fill.ForeColor.RGB = vbGreen
            .Line.Visible = False
            .Line.ForeColor.RGB = vbGreen
            .Line.Weight = LWT
            .Line.Transparency = 0
        Else
            MsgBox "Shape name [" & sName & "] is already taken."  _
            & vbCrLf & "Please restart.", vbExclamation, "Restart"
            .Delete
        End If
    End With
    
  Set shp2 = ws.Shapes.AddShape(9, _
                                rng.Left + 19, _
                                rng.Top + ((rng.Height - DIA) / 2), _
                                DIA, _
                                DIA)
    With shp2
'        Dim sName As String
        sName = Application.InputBox(Title:="3/3 Enter Name Level 2", _
                                     Default:="Click L2 ", _
                                     Prompt:="", _
                                     Type:=2)
        If Not ValidateName(sName) Then
            MsgBox "Shape name [" & sName & "] is duplicated."  _
            & vbCrLf & "Please try again.", vbExclamation, "Duplicate"
            sName = Application.InputBox(Title:="3/3 Enter Name Level 2", _
                                         Default:="Click L2 ", _
                                         Prompt:="", _
                                         Type:=2)
        End If
        If ValidateName(sName) Then
            .Name = sName
            .Shadow.Visible = False
            .Fill.Visible = True
            .Fill.ForeColor.RGB = vbGreen
            .Line.Visible = False
            .Line.ForeColor.RGB = vbGreen
            .Line.Weight = LWT
            .Line.Transparency = 0
        Else
            MsgBox "Shape name [" & sName & "] is already taken."  _
            & vbCrLf & "Please restart.", vbExclamation, "Restart" 
            .Delete
        End If
    End With
    
  MsgBox "Shape Names:" & vbNewLine & vbNewLine & _
               "" & shp1.Name & vbNewLine & _
               "" & shp2.Name, , ""
    
End Sub
'========================================================================

Function ValidateName(ByVal ShpName As String) As Boolean
    Dim s As Shape
    On Error Resume Next
    Set s = ActiveSheet.Shapes(ShpName)
    On Error GoTo 0
    ValidateName = (s Is Nothing)
End Function
'========================================================================

This is the second solution, using:

  • "User may retry X times"

The user has X retries to name the shapes with a unique name.

Issue: The shp-1-"try again"-prompt works properly. The shp-2-"try again"-prompt has unlimited retries.

Option Explicit

'========================================================================
' InputBox: Add Shapes for Buttons v3 UPDATE v1
'========================================================================
' Buttons: 2
' Cell Size: Width 47
' Button Size: DIA
' Line Weight: LWT
' Shape Type: msoShapeOval, No 9
'========================================================================

Sub IPB_AddShapes_Buttons_000_v3_UPDATE_v1()

Dim ws As Worksheet

Dim rng As Range
Dim shp1 As Shape
Dim shp2 As Shape

Const DIA As Single = 9
Const LWT As Single = 1

Dim sName As String, iCnt As Long
Const MAX_TRY = 3  ' max tries

On Error Resume Next

Set ws = ActiveSheet

Set rng = Application.InputBox(Title:="1/3 Select Shape Range", _
                               Prompt:="", _
                               Type:=8)

  Set shp1 = ws.Shapes.AddShape(9, _
                                rng.Left + 5, _
                                rng.Top + ((rng.Height - DIA) / 2), _
                                DIA, _
                                DIA)
    With shp1
'        Dim sName As String, iCnt As Long
'        Const MAX_TRY = 3  ' max tries
        Do
            If Len(sName) > 0 Then
                MsgBox "Shape name [" & sName & "] is duplicated."  _
                & vbCrLf & "Please try again.", vbExclamation, "Duplicate"
            End If
            sName = Application.InputBox(Title:="2/3 Enter Name Level 1", _
                                         Default:="Click L1 ", _
                                         Prompt:="", _
                                         Type:=2)
            iCnt = iCnt + 1
        Loop Until ValidateName(sName) Or iCnt = MAX_TRY
        If ValidateName(sName) Then
            .Name = sName
            .Shadow.Visible = False
            .Fill.Visible = True
            .Fill.ForeColor.RGB = vbGreen
            .Line.Visible = False
            .Line.ForeColor.RGB = vbGreen
            .Line.Weight = LWT
            .Line.Transparency = 0
        Else
            MsgBox "Shape name [" & sName & "] is already taken."  _
            & vbCrLf & "Please restart.", vbExclamation, "Restart"
            .Delete
        End If        
    End With
    
  Set shp2 = ws.Shapes.AddShape(9, _
                                rng.Left + 19, _
                                rng.Top + ((rng.Height - DIA) / 2), _
                                DIA, _
                                DIA)
    With shp2
'        Dim sName As String, iCnt As Long
'        Const MAX_TRY = 3  ' max tries
        Do
            If Len(sName) > 0 Then
                MsgBox "Shape name [" & sName & "] is duplicated."  _
                & vbCrLf & "Please try again.", vbExclamation, "Duplicate"
            End If
            sName = Application.InputBox(Title:="3/3 Enter Name Level 2", _
                                         Default:="Click L2 ", _
                                         Prompt:="", _
                                         Type:=2)
            iCnt = iCnt + 1
        Loop Until ValidateName(sName) Or iCnt = MAX_TRY
        If ValidateName(sName) Then
            .Name = sName
            .Shadow.Visible = False
            .Fill.Visible = True
            .Fill.ForeColor.RGB = vbGreen
            .Line.Visible = False
            .Line.ForeColor.RGB = vbGreen
            .Line.Weight = LWT
            .Line.Transparency = 0
        Else
            MsgBox "Shape name [" & sName & "] is already taken."  _
            & vbCrLf & "Please restart.", vbExclamation, "Restart"
            .Delete
        End If
    End With
    
  MsgBox "Shape Names:" & vbNewLine & vbNewLine & _
               "" & shp1.Name & vbNewLine & _
               "" & shp2.Name, , ""
    
End Sub
'========================================================================

Function ValidateName(ByVal ShpName As String) As Boolean
    Dim s As Shape
    On Error Resume Next
    Set s = ActiveSheet.Shapes(ShpName)
    On Error GoTo 0
    ValidateName = (s Is Nothing)
End Function
'========================================================================
Improve this question

1 Answer 1

Reset to default
1
  • Add an UDF to validate user's input.
Sub IPB_AddShapes_Buttons_v3()
    ' your code ...
    
    With shp1
        Dim sName As String
        sName = Application.InputBox(Title:="2/3 Enter Name Level 1", _
                                     Default:="Click L1 ", _
                                     Prompt:="", _
                                     Type:=2)
        If Not ValidateName(sName) Then
            MsgBox "Shape name [" & sName & "] is duplicated. Try again."
            sName = Application.InputBox(Title:="2/3 Enter Name Level 1", _
                             Default:="Click L1 ", _
                             Prompt:="", _
                             Type:=2)
        End If
        If ValidateName(sName) Then
            .Name = sName
            .Shadow.Visible = False
            .Fill.Visible = True
            .Fill.ForeColor.RGB = vbGreen
            .Line.Visible = False
            .Line.ForeColor.RGB = vbGreen
            .Line.Weight = LWT
            .Line.Transparency = 0
        Else
            MsgBox "Shape name [" & sName & "] is duplicated"
            .Delete
        End If
    End With
    
    ' your code ...
    
End Sub

Function ValidateName(ByVal ShpName As String) As Boolean
    Dim s As Shape
    ShpName = UCase(ShpName)
    For Each s In ActiveSheet.Shapes
        If UCase(s.Name) = ShpName Then
            ValidateName = False
            Exit Function
        End If
    Next
    ValidateName = True
End Function
  • User may retry X times
    With shp1
        Dim sName As String, iCnt As Long
        Const MAX_TRY = 3  ' max tries
        Do
            If Len(sName) > 0 Then
                MsgBox "Shape name [" & sName & "] is duplicated." & vbCrLf & "Please try again."
            End If
            sName = Application.InputBox(Title:="2/3 Enter Name Level 1", _
                                         Default:="Click L1 ", _
                                         Prompt:="", _
                                         Type:=2)
            iCnt = iCnt + 1
        Loop Until ValidateName(sName) Or iCnt = MAX_TRY
        If ValidateName(sName) Then
            .Name = sName
            .Shadow.Visible = False
            .Fill.Visible = True
            .Fill.ForeColor.RGB = vbGreen
            .Line.Visible = False
            .Line.ForeColor.RGB = vbGreen
            .Line.Weight = LWT
            .Line.Transparency = 0
        Else
            MsgBox "Shape name [" & sName & "] is duplicated"
            .Delete
        End If
    End With
  • Another option UDF
Function ValidateName(ByVal ShpName As String) As Boolean
    Dim s As Shape
    On Error Resume Next
    Set s = ActiveSheet.Shapes(ShpName)
    On Error GoTo 0
    ValidateName = (s Is Nothing)
End Function
Improve this answer
4
  • And how would you include a "try again"-prompt after a "duplicate"-alert?
    – user23636411
    Commented May 6 at 19:47
  • 1
    The updated code gives users more retry opportunities.
    – taller
    Commented May 6 at 20:04
  • How do you modify "User may retry X times" to work for both shapes?
    – user23636411
    Commented May 7 at 21:33
  • 1
    Duplicate With shp1 ... End With. Change shp1 > shp2 and inputbox arguments.
    – taller
    Commented May 7 at 22:36

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.