Excel 输入框：用唯一名称命名形状

Question

此代码允许您将形状添加到单元格范围。

在此示例中，它向选定范围添加 2 个椭圆。

它有 2 个输入框：

• 选择形状范围
• 输入形状名称

如何构建“输入形状名称”输入框以确保每个形状都有唯一的名称，并有一个消息框显示“此名称已被占用”？

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

Answer 1

• 添加UDF来验证用户的输入。

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