CODEWITHSUNDEEP
excelvbashapesgroupinputbox
user23636411
user23636411

Reputation: 109

Excel InputBox: group shapes and name groups with unique names

This code allows the user to group shapes in a selected range and name the group with a unique name.

It uses 2 InputBoxes:

Bug: If the user selects a range that is already grouped, the code stops working. Error: "Run-time error '438': Object doesn't support this property or method."

How do you insert a MsgBox at the beginning saying: "The selected shapes are already grouped. Please change your selection." and make the code only run, if the selection is "valid"?

Option Explicit
'===============================================================================
' InputBox: Group Shapes and Name Group v4.0
'===============================================================================
Sub IPB_Group_Shapes_v4_0()
Dim ws As Worksheet
Dim shp As Shape
Dim rng As Range
Dim grp As Object
Set ws = ActiveSheet
'Application.ScreenUpdating = False
  On Error Resume Next
    Set rng = Application.InputBox(Title:="1/2 Select Shape Range", _
                                   Prompt:="", _
                                   Type:=8)
  On Error GoTo 0
  If Not rng Is Nothing Then
    'Hide any Shape Outside Selected Range
      For Each shp In ws.Shapes
        If Intersect(rng, shp.TopLeftCell) Is Nothing And _
          Intersect(rng, shp.BottomRightCell) Is Nothing Then
             If shp.Type <> msoComment Then shp.Visible = msoFalse
        End If
      Next shp
    'Select All Visible Shapes
      On Error GoTo Skip
        ws.Shapes.SelectAll
      On Error GoTo 0
    'Group Shapes and Name Group with unique name
      If VarType(Selection) = 9 Then
        Set grp = Selection.Group        
        With grp
            Dim gName As String
            gName = Application.InputBox(Title:="2/2 Enter Group Name", _
                                         Default:="ClickGroup [00 Name] ", _
                                         Prompt:="", _
                                         Type:=2)
            If Not ValidateName(gName) Then
               MsgBox "Group name [" & gName & "] is duplicated." _
               & vbCrLf & "Try again.", vbExclamation, "Duplicate"
               gName = Application.InputBox(Title:="2/2 Enter Group Name", _
                                            Default:="ClickGroup [00 Name] ", _
                                            Prompt:="", _
                                            Type:=2)
            End If
            If ValidateName(gName) Then
                grp.Name = gName
            Else
                MsgBox "Group name [" & gName & "] is already taken." _
                & vbCrLf & "Please restart.", vbExclamation, "Restart"
                grp.Select
            End If
        End With
    MsgBox "Group Name:" & vbNewLine & vbNewLine & _
                 "" & grp.Name, , ""  
        grp.Select
      End If
Skip:
    'Unhide rest of the Shapes
      For Each shp In ws.Shapes
        If shp.Type <> msoComment Then
          If shp.Visible = msoFalse Then shp.Visible = msoTrue
        End If
      Next shp
  End If
End Sub
'===============================================================================

Idea:

If Selection Is grp Then
MsgBox "These Shapes are already grouped.", vbExclamation, "Please retry."
Else
End If

Upvotes: 0

Views: 62

Answers (1)

taller
taller

Reputation: 18762

  • ActiveSheet.Shapes.Range(..).Select select the desired shapes
  • The If to determine whether the shape cross with selected range is not reliable. eg. shape's TopRightCell may be in the selected range. Change the code to :
If Not Intersect(rng, Range(shp.TopLeftCell, shp.BottomRightCell)) Is Nothing Then

Option Explicit
'===============================================================================
' InputBox: Group Shapes and Name Group v4.0
'===============================================================================
Sub IPB_Group_Shapes_v4_0()
Dim ws As Worksheet
Dim shp As Shape
Dim rng As Range
Dim grp As Object
Dim aShp(), iR As Long
Set ws = ActiveSheet
'Application.ScreenUpdating = False
  On Error Resume Next
    Set rng = Application.InputBox(Title:="1/2 Select Shape Range", _
                                   Prompt:="", _
                                   Type:=8)
  On Error GoTo 0
  If Not rng Is Nothing Then
    ReDim aShp(1 To ws.Shapes.Count)
    'Hide any Shape Outside Selected Range
      For Each shp In ws.Shapes
        If Not Intersect(rng, Range(shp.TopLeftCell, shp.BottomRightCell)) Is Nothing Then
            If shp.Type <> msoComment Then
                iR = iR + 1
                aShp(iR) = shp.Name
            End If
        End If
      Next shp
      If iR = 0 Then Exit Sub ' no shape in selected range
      ReDim Preserve aShp(1 To iR)
    'Group Shapes and Name Group with unique name
      If iR > 1 Then ' more than one shapes
        ' ***
        ActiveSheet.Shapes.Range(aShp).Select ' select shapes
        Set grp = Selection.ShapeRange.Group  ' group shapes
        ' ***
        With grp
            Dim gName As String
            gName = Application.InputBox(Title:="2/2 Enter Group Name", _
                                         Default:="ClickGroup [00 Name] ", _
                                         Prompt:="", _
                                         Type:=2)
            If Not ValidateName(gName) Then
               MsgBox "Group name [" & gName & "] is duplicated." _
               & vbCrLf & "Try again.", vbExclamation, "Duplicate"
               gName = Application.InputBox(Title:="2/2 Enter Group Name", _
                                            Default:="ClickGroup [00 Name] ", _
                                            Prompt:="", _
                                            Type:=2)
            End If
            If ValidateName(gName) Then
                grp.Name = gName
            Else
                MsgBox "Group name [" & gName & "] is already taken." _
                & vbCrLf & "Please restart.", vbExclamation, "Restart"
                grp.Select
            End If
        End With
    MsgBox "Group Name:" & vbNewLine & vbNewLine & _
                 "" & grp.Name, , ""
        grp.Select
      End If
Skip:
    'Unhide rest of the Shapes
    ' pass
  End If
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

Upvotes: 1

Related Questions