excelvbashapesnamesinputbox

Excel InputBox: name shapes with unique names


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

It uses 3 InputBoxes:

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:

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:

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
'========================================================================



Solution

  • 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
    
        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
    
    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