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