VBA for executing macro when a shape is moved/altered?

[frabulator]

I am looking for a way to execute a macro when an object with a specific name is updated, moved or changed. Is this possible, and if it is, could someone please point me in the correct direction or give me a sample code?

Many thanks!

Frab~

 

[Jaafar Tribak]

Re: VBA for exicuting macro when a shape is moved/altered?

While that is neat, and I think it would work in many situations, it will not work for what I want to do. If the rectangle is resized I will need to redraw the shapes inside of it as they should not be scaled with the rectangle. The shapes inside need to stay the same aspect ration when the rectangle is resized.

Excel doesn't offer a native event that fires when a shape is resized or moved however you can perform the following vba trick to emulate a pseudo-event for this purpose.

Place this in the ThisWorkbook Module :

Option Explicit

Private WithEvents cmbrs As CommandBars
Private lTotalShapes As Long
Private oPrevSheet As Worksheet

Private Sub Workbook_Activate()
    Call TagShapes
End Sub

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    Call TagShapes
End Sub

Private Sub TagShapes()
    Dim oShp As Shape, oGrpShape As Shape
    On Error Resume Next
    
    For Each oShp In ActiveSheet.Shapes
        oShp.AlternativeText = CStr(oShp.Left) & "*" & CStr(oShp.Top) & "*" & CStr(oShp.Width) & "*" & CStr(oShp.Height)
        lTotalShapes = lTotalShapes + 1
    Next
    Set oPrevSheet = ActiveSheet
    Set cmbrs = Application.CommandBars
End Sub

Private Sub cmbrs_OnUpdate()
    Dim sTagsArray()  As String
    Dim oShp As Shape, oGrpShape As Shape
    Dim bCancel As Boolean
    
    If oPrevSheet.Name <> ActiveSheet.Name Or ActiveSheet.Shapes.Count <> lTotalShapes Then lTotalShapes = 0: Call TagShapes: Exit Sub
    If TypeName(Selection) = "Range" Or TypeName(Selection) = "Nothing" Then Exit Sub
    For Each oShp In ActiveSheet.Shapes
        With oShp
            sTagsArray = Split(.AlternativeText, "*")
            If sTagsArray(0) <> CStr(.Left) Or sTagsArray(1) <> CStr(.Top) Or _
            sTagsArray(2) <> CStr(.Width) Or sTagsArray(3) <> CStr(.Height) Then
            Call Shapes_AfterMoveOrResize(oShp, .Left, .Top, .Width, .Height, bCancel)
            If bCancel Then Application.Undo
                Call TagShapes
                Exit Sub
            End If
        End With
    Next
    Set oPrevSheet = ActiveSheet
End Sub

[B][COLOR=#008000]'==================================================================[/COLOR][/B]
[B][COLOR=#008000]'Pseudo-event routine that fires when any shape is moved or resized[/COLOR][/B]
[B][COLOR=#008000]' - Set the Cancel argument to TRUE to undo the moving or resizing[/COLOR][/B]
[B][COLOR=#008000]'==================================================================[/COLOR][/B]
Private Sub Shapes_AfterMoveOrResize _
    ( _
        ByVal Shp As Shape, _
        ByVal x As Single, _
        ByVal y As Single, _
        ByVal cx As Single, _
        ByVal cy As Single, _
        ByRef Cancel As Boolean _
    )
    
    Dim sMsg As String
    
[B][COLOR=#008000]    'Cancel = True <=== Set this arg to TRUE to undo the operation !!![/COLOR][/B]
    
    sMsg = Space(20) & vbNewLine & vbNewLine
    
    sMsg = sMsg & "You have altered the size or the position" & vbNewLine & "of the shape : " & _
    "( " & Shp.Name & " )" & vbNewLine & vbNewLine
    
    sMsg = sMsg & "   - New LEFT Value := (" & x & " pt" & ")" & vbNewLine & vbNewLine
    sMsg = sMsg & "   - New TOP Value := (" & y & " pt" & ")" & vbNewLine & vbNewLine
    sMsg = sMsg & "   - New WIDTH Value := (" & cx & " pt" & ")" & vbNewLine & vbNewLine
    sMsg = sMsg & "   - New HEIGHT Value := (" & cy & " pt" & ")" & vbNewLine & vbNewLine
    sMsg = sMsg & "   - Cancel Move\Resize Opeartion : (" & IIf(Cancel, "Yes", "No") & ")"
    
    MsgBox sMsg, vbInformation, "Shape Move\Resize Pseudo-Event."
End Sub

In your specific case scenario, you should adapt the above generic pseudo-event routine to something along these lines :

Assuming the shapes are grouped together and the group is "Group 1".. Change the group name to suit.

[B][COLOR=#008000]'==================================================================
'Pseudo-event routine that fires when any shape is moved or resized
' - Set the Cancel argument to TRUE to undo the moving or resizing
'==================================================================[/COLOR][/B]
Private Sub Shapes_AfterMoveOrResize _
    ( _
        ByVal Shp As Shape, _
        ByVal x As Single, _
        ByVal y As Single, _
        ByVal cx As Single, _
        ByVal cy As Single, _
        ByRef Cancel As Boolean _
    )
    
    If Shp.Name = "Group 1" Then
[B][COLOR=#008000]        ' Call you Macro here to redraw the shapes inside the container shape....[/COLOR][/B]
    End If
End Sub

One bad side effect of this approach is that it disables the excel Undo functionality.