This code allows you to add shapes to a cell range.
In this example, it adds 2 ovals to the selected range.
It has 2 Inputboxes:
- Select Shape Range
- Enter Shape Name
How do you build the "Enter Shape Name"-Inputbox to ensure a unique name for 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
'========================================================================
>Solution :
- 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 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