Group shapes created by VBA

DennisPedersen
DennisPedersen used Ask the Experts™
on
Hi,

I have created a macro, where I create to shapes. Now I would like them to be grouped together after they are created, but I'm not able to figure it out.

Thanks in advance.

Test.xlsm
Comment
Watch Question

Do more with

Expert Office
EXPERT OFFICE® is a registered trademark of EXPERTS EXCHANGE®
Looks like the file did not upload fully. Please resend.
Commented:
I think this does what you're looking for ...

Sub DrawTextBox()

    With ActiveCell
        Set ThisLine = ActiveSheet.Shapes.AddTextbox(msoShapeRectangle, .Left + 20, .Top - 12, 100, 11)
        ThisLine.TextFrame.Characters.Text = ""
        ThisLine.Select
        
    '**********************
    ' New code
        thisLineName = Selection.Name
    '**********************
        
        With Selection.ShapeRange.Fill
            .Visible = msoTrue
            .ForeColor.RGB = RGB(68, 133, 159)
            .Transparency = 0
            .Solid
        End With
        
        With Selection.ShapeRange.Line
            .Visible = msoTrue
            .ForeColor.ObjectThemeColor = msoThemeColorBackground1
'            .ForeColor.TintAndShade = 0
'            .ForeColor.Brightness = 0
            .Transparency = 1
        End With
        
        With Selection.Font
            .Name = "Verdana"
            .FontStyle = "Normal"
            .Size = 7
            .Strikethrough = False
            .Superscript = False
            .Subscript = False
            .OutlineFont = False
            .Shadow = False
            .Underline = xlUnderlineStyleNone
            .ColorIndex = xlAutomatic
            .Color = RGB(255, 255, 255)
        End With
        
        Selection.ShapeRange.TextFrame2.MarginTop = 2.8346456693
        Selection.ShapeRange.TextFrame2.MarginBottom = 2.8346456693
        Selection.ShapeRange.TextFrame2.MarginRight = 2.8346456693
        Selection.ShapeRange.TextFrame2.MarginLeft = 2.8346456693
        With Selection.ShapeRange.TextFrame2
            .VerticalAnchor = msoAnchorMiddle
            .HorizontalAnchor = msoAnchorNone
        End With
        
        Set ThisLine2 = ActiveSheet.Shapes.AddConnector(msoConnectorStraight, .Left + 20, .Top - 10, .Left + 8.5, .Top)
        ThisLine2.Select
        
    '**********************
    ' New code
        thisLine2Name = Selection.Name
    '**********************
        
        With Selection.ShapeRange.Line
            .EndArrowheadStyle = msoArrowheadOpen
            .ForeColor.RGB = RGB(68, 133, 159)
            .Weight = 1.5
        End With
    
    '**********************
    ' New code
    
        Set my_range = ActiveSheet.Shapes.Range(Array(thisLineName, thisLine2Name))
        Set my_group = my_range.Group
        my_group.Name = "MyGroupName"
    '**********************
        
    End With

End Sub

Open in new window

Test-sdw.xlsm

Author

Commented:
Thank you, this works perfect :-)

Do more with

Expert Office
Submit tech questions to Ask the Experts™ at any time to receive solutions, advice, and new ideas from leading industry professionals.

Start 7-Day Free Trial