Home Why am i not able to group these two shapes in vba excel?
Reply: 1

Why am i not able to group these two shapes in vba excel?

Ammar Ahmad
1#
Ammar Ahmad Published in 2018-01-12 15:00:41Z

The immediate objective is to be able to group two shapes into a grouping ao they can be dragged around together. I have created both shapes but when the code runs the shapes are still not grouped I am relatively new to vba so im sure I am using some functionality incorrectly. This is the immediate code which I tried:

'Group the two boxes together
    Dim ShapeArray As Variant
    ShapeArray(0) = Box1.Name
    ShapeArray(1) = ActiveShape.Name

    ActiveSheet.Shapes.Range(ShapeArray(0, 1)).Group

The Full module code for context is as follows:

Sub Button2_Click()

    Dim ActiveShape As Shape
    Dim UserSelection As Variant

        'Pull-in what is selected on screen
    Set UserSelection = ActiveWindow.Selection

        'Determine if selection is a shape
    On Error GoTo NoShapeSelected
    Set ActiveShape = ActiveSheet.Shapes(UserSelection.Name)
    On Error Resume Next

        'Do Something with your Shape variable
    With ActiveShape.line    'Add border
        .Weight = 5
        .ForeColor.RGB = RGB(21, 2, 191)
    End With
        'Create a Shape inside the shape
    Dim Box1 As Shape
    Dim tope

    tope = ActiveShape.TOP
    Set Box1 = Sheet1.Shapes.AddTextbox(msoTextOrientationHorizontal, ActiveShape.Left, tope, 10, 10)
    Box1.Fill.ForeColor.RGB = RGB(40, 30, 166)

    'Group the two boxes together
    Dim ShapeArray As Variant
    ShapeArray(0) = Box1.Name
    ShapeArray(1) = ActiveShape.Name

    ActiveSheet.Shapes.Range(ShapeArray(0, 1)).Group






    temp1 = ActiveShape.TextFrame.Characters.Caption

    If InStr(temp1, "In Prog") = 0 Then      ' Add Text
        selTxt = Split(temp1, Chr(10))
        shp.OLEFormat.Object.Caption = selTxt(0) & "             " & "In Prog"
                    For i = 1 To (UBound(selectText) - 1)
                        shp.OLEFormat.Object.Caption = selectText(i) & vbNewLine
                    Next i

    ActiveShape.TextFrame.Characters.Caption = ActiveShape.TextFrame.Characters.Caption & vbNewLine & "In Prog"
    End If




    'Error Handler
NoShapeSelected:
        MsgBox "You do not have a shape selected!"


End Sub

Basically after highlighting a box, you can press a button in excel which augments this box in several ways as shown by the comments (adds borders and a box inside the old one). I would like the newly created box to group with the old one or collapse in some way so it is easy to drag around. If there is another easier way to select both of these boxes I would love to hear the input. Also these two boxes are not found in select rows or column of cells and can be anywhere in the worksheet so I cant apply ranges. Thank you for any help you may provide. If any other clarification is required or I forgot something pertinent to the problem please don't hesitate to ask. Thanks to all in advance!

Edit: The rest of the code is as follows:

The Worksheet Code:

Option Explicit
Public alltxt As String
Private selectText() As String

Private Sub CommandButton1_Click()
    UF1.Show
End Sub



Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim ws As Worksheet
    Set ws = Target.Parent
    Dim temp
    Dim i

    Dim shp As Shape
    Dim line As Variant
    For Each shp In ws.Shapes   'loop through all shapes
        If shp.Type = msoShapeRectangle Then 'that are text boxes
            'write the header cells into the text box
            temp = shp.OLEFormat.Object.Caption
            'OLEFormat.Object.Caption
                If InStr(temp, "week") = 0 And InStr(temp, "In Prog") = 0 Then
                    shp.OLEFormat.Object.Caption = shp.OLEFormat.Object.Caption & vbNewLine & ws.Cells(4, shp.TopLeftCell.Column).Text & " - " & ws.Cells(4, shp.BottomRightCell.Column).Text
                ElseIf InStr(temp, "week") And InStr(temp, "In Prog") Then
                    selectText = Split(temp, Chr(10))
                    shp.OLEFormat.Object.Caption = ""
                    For i = 0 To (UBound(selectText) - 3)
                        shp.OLEFormat.Object.Caption = shp.OLEFormat.Object.Caption & selectText(i) & vbNewLine
                    Next i
                    shp.OLEFormat.Object.Caption = shp.OLEFormat.Object.Caption & vbNewLine & ws.Cells(4, shp.TopLeftCell.Column).Text & " - " & ws.Cells(4, shp.BottomRightCell.Column).Text & vbNewLine & "In Prog"
                ElseIf InStr(temp, "week") And InStr(temp, "In Prog") = 0 Then
                    selectText = Split(shp.OLEFormat.Object.Caption, Chr(10))
                    shp.OLEFormat.Object.Caption = ws.Cells(4, shp.TopLeftCell.Column).Text & " - " & ws.Cells(4, shp.BottomRightCell.Column).Text
                    For i = (UBound(selectText) - 1) To 0 Step -1
                        shp.OLEFormat.Object.Caption = selectText(i) & vbNewLine & shp.OLEFormat.Object.Caption
                    Next i
                End If

        End If
    Next shp
End Sub

The Userform Code:

Private Sub UserForm_Initialize()

'fill combobox catagory
Me.cmbCAT.AddItem "L1U"
Me.cmbCAT.AddItem "L1L"
Me.cmbCAT.AddItem "IN"
Me.cmbCAT.AddItem "SC"
Me.cmbCAT.AddItem "GE"
Me.cmbCAT.AddItem "TE"
Me.cmbCAT.AddItem "ExD"


'fill combobox resources
Me.cmbResource.AddItem "Item1"
Me.cmbResource.AddItem "Item2"

End Sub


Private Sub btnSubmit_Click()

Dim wrks As Worksheet
Set wrks = ThisWorkbook.Sheets("Sheet1")

Dim typ As String
typ = cmbCAT.Text

Dim Box As Shape
Set Box = Sheet1.Shapes.AddShape(msoShapeRectangle, 100, 100, 200, 60)
'AddTextbox(msoTextOrientationHorizontal, 100, 100, 200, 60)

If typ = "L1U" Then
    Box.Fill.ForeColor.RGB = RGB(255, 180, 18)
ElseIf typ = "L1L" Then
    Box.Fill.ForeColor.RGB = RGB(147, 196, 22)
ElseIf typ = "SC" Then
    Box.Fill.ForeColor.RGB = RGB(147, 196, 22)
ElseIf typ = "IN" Then
    Box.Fill.ForeColor.RGB = RGB(255, 255, 70)
ElseIf cmbCAT = "GE" Then
    Box.Fill.ForeColor.RGB = RGB(255, 173, 203)
ElseIf cmbCAT = "TE" Then
    Box.Fill.ForeColor.RGB = RGB(114, 163, 255)
Else
    Box.Fill.ForeColor.RGB = RGB(159, 2, 227)
End If

Box.TextFrame.Characters.Caption = tbSP & "-" & tbDROP & "." & cmbCAT & "." & tbUS & vbNewLine & _
"Resource: " & cmbResource & vbNewLine & _
"Description: " & tbDES & vbNewLine



Unload UF1

End Sub
QHarr
2#
QHarr Reply to 2018-01-12 15:56:58Z

Try the following, the general syntax is Range(Array("shape1", "shape2")).Group

 Dim ShapeArray(0 To 1) As String
 ShapeArray(0) = Box1.Name
 ShapeArray(1) = ActiveShape.Name

 ActiveSheet.Shapes.Range(Array(ShapeArray(0), ShapeArray(1))).Group
You need to login account before you can post.

About| Privacy statement| Terms of Service| Advertising| Contact us| Help| Sitemap|
Processed in 0.390484 second(s) , Gzip On .

© 2016 Powered by mzan.com design MATCHINFO