Event triggered when a shape is moved (ShapeMove Pseudo-Event)

Jaafar Tribak

Jaafar Tribak

Well-known Member
Joined
Dec 5, 2002
Messages
9,797
Office Version
  1. 2016
Platform
  1. Windows
Hi all,

This is a little vba class that you can add to your project in order to catch mouse drag and dop operations performed on shapes embedeed on worksheets.

The code doesn't use a timer nor does it use a loop so it is safe and should have much less impact on performance.

If you set the OnAction property for a shape, then the mouse cursor changes to a hand when it is over the shape, and you can detect a mouse click on the shape, but you cannot drag and drop the shape.. So the solution to this problem is to brievely press the SHIFT key while pointing over the shape with the mouse cursor .. This will automatically select the shape so you can start dragging it around.

This is the pseudo-event signature:

VBA Code: 
Private Sub Shapes_AfterDragOver _( _
    ByVal DragedShape As Shape, _
    ByVal DropTarget As Object, _
    ByVal x As Single, _
    ByVal y As Single, _
    ByRef Cancel As Boolean _
)

Workbook Demo

Add a Class Module to your project and give it the name of ShapesMoveEventClss

Class Code :
VBA Code: 
Option Explicit

Public Event AfterDragOver _
( _
    ByVal DragedShape As Shape, _
    ByVal DropTarget As Object, _
    ByVal x As Single, _
    ByVal y As Single, _
    ByRef Cancel As Boolean _
)

Private WithEvents CmbrsEvent As CommandBars

Private Type POINTAPI
    x As Long
    y As Long
End Type

#If VBA7 Then
    Private Declare PtrSafe Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
    Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hdc As LongPtr) As Long
    Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hdc As LongPtr, ByVal nIndex As Long) As Long
    Private Declare PtrSafe Function CreateEllipticRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As LongPtr
    Private Declare PtrSafe Function FillRgn Lib "gdi32" (ByVal hdc As LongPtr, ByVal hRgn As LongPtr, ByVal hBrush As LongPtr) As Long
    Private Declare PtrSafe Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As LongPtr
    Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hdc As LongPtr, ByVal hObject As LongPtr) As LongPtr
    Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
    Private Declare PtrSafe Function InvalidateRgn Lib "user32" (ByVal hwnd As LongPtr, ByVal hRgn As LongPtr, ByVal bErase As Long) As Long
    Private Declare PtrSafe Function ScreenToClient Lib "user32" (ByVal hwnd As LongPtr, lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Function FrameRgn Lib "gdi32" (ByVal hdc As LongPtr, ByVal hRgn As LongPtr, ByVal hBrush As LongPtr, ByVal nWidth As Long, ByVal nHeight As Long) As Long
   
    Private hRoundRgn As LongPtr, hdc As LongPtr, hBrush As LongPtr, hBrush2 As LongPtr
#Else
    Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
    Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
    Private Declare Function CreateEllipticRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
    Private Declare Function FillRgn Lib "gdi32" (ByVal hdc As Long, ByVal hRgn As Long, ByVal hBrush As Long) As Long
    Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
    Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
    Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
    Private Declare Function InvalidateRgn Lib "user32" (ByVal hwnd As Long, ByVal hRgn As Long, ByVal bErase As Long) As Long
    Private Declare Function ScreenToClient Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
    Private Declare Function FrameRgn Lib "gdi32" (ByVal hdc As Long, ByVal hRgn As Long, ByVal hBrush As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long

    Private hRoundRgn As Long, hdc As Long, hBrush As Long, hBrush2 As Long
#End If


Private Const LOGPIXELSX As Long = 88
Private Const LOGPIXELSY As Long = 90
Private Const POINTSPERINCH = 72

Private oSh As Worksheet
Private lTotalShapes As Long

Private Sub Class_Initialize()
    Call TagShapes
End Sub

Private Sub Class_Terminate()
    Set CmbrsEvent = Nothing
End Sub

Public Sub ApplyToSheet(ByVal Sh As Worksheet)
    Set oSh = Sh
End Sub

Private Sub CmbrsEvent_OnUpdate()
    Dim tCurPos As POINTAPI
    Dim tCenterShapePos As POINTAPI
    Dim oDropTarget As Object
    Dim bCancel As Boolean
    Dim oShape As Shape
    Dim sTagsArray() As String

    On Error Resume Next
   
    If Not (ActiveSheet Is oSh) Then Exit Sub
    If ActiveSheet.Shapes.Count <> lTotalShapes Then lTotalShapes = 0: Call TagShapes: Exit Sub
   
    Application.CommandBars.FindControl(ID:=2040).Enabled = Not Application.CommandBars.FindControl(ID:=2040).Enabled
   
    GetCursorPos tCurPos
    Set oShape = ActiveSheet.Shapes(ActiveWindow.RangeFromPoint(tCurPos.x, tCurPos.y).Name)
   
    If TypeName(oShape) <> "Range" Then
        sTagsArray = Split(oShape.AlternativeText, "*")
        If GetAsyncKeyState(VBA.vbKeyShift) Then
            oShape.Select
        End If
    End If
   
    With oShape
        .ZOrder msoBringToFront
        If sTagsArray(0) <> CStr(.Left) Or sTagsArray(1) <> CStr(.Top) Then
            tCenterShapePos = ShapeMiddlePTtoPX(oShape)
           
            ToggleVisibility oShape
            DoEvents
                .Visible = False
            DoEvents
            Set oDropTarget = ActiveWindow.RangeFromPoint(tCenterShapePos.x, tCenterShapePos.y)
            DoEvents
                .Visible = True
            DoEvents
   
            If TypeName(ActiveWindow.RangeFromPoint(tCurPos.x, tCurPos.y)) <> "Range" And _
            TypeName(ActiveWindow.RangeFromPoint(tCurPos.x, tCurPos.y)) <> "Nothing" Then
                DrawCircle tCenterShapePos
                RaiseEvent AfterDragOver(oShape, oDropTarget, .Left, .Top, bCancel)
                InvalidateRgn Application.hwnd, hRoundRgn, 0
                ToggleVisibility oShape
                If bCancel Then .Left = sTagsArray(0): .Top = sTagsArray(1)
            End If
        DoEvents
        End If
        .AlternativeText = CStr(.Left) & "*" & CStr(.Top)
    End With
     
End Sub

Private Sub TagShapes()

    Dim oShp As Shape
   
    For Each oShp In ActiveSheet.Shapes
        oShp.AlternativeText = CStr(oShp.Left) & "*" & CStr(oShp.Top)
        lTotalShapes = lTotalShapes + 1
    Next
    Set CmbrsEvent = Application.CommandBars

End Sub

Private Function ScreenDPI(bVert As Boolean) As Long
 
    Static lDPI(1), lDC
   
    If lDPI(0) = 0 Then
        lDC = GetDC(0)
        lDPI(0) = GetDeviceCaps(lDC, LOGPIXELSX)
        lDPI(1) = GetDeviceCaps(lDC, LOGPIXELSY)
        lDC = ReleaseDC(0, lDC)
    End If
 
    ScreenDPI = lDPI(Abs(bVert))
 
End Function
 
Private Function PTtoPX _
(Points As Double, bVert As Boolean) As Long
 
    PTtoPX = Points * ScreenDPI(bVert) / POINTSPERINCH
 
End Function

Private Function ShapeMiddlePTtoPX(ByVal Shp As Shape) As POINTAPI

    Dim OWnd  As Window
   
    Set OWnd = Shp.Parent.Parent.Windows(1)
    With Shp
        ShapeMiddlePTtoPX.x = PTtoPX((.Left + (.Width / 2)) * OWnd.Zoom / 100, 0) _
        + OWnd.PointsToScreenPixelsX(0)
        ShapeMiddlePTtoPX.y = PTtoPX((.Top + (.Height / 2)) * OWnd.Zoom / 100, 1) _
        + OWnd.PointsToScreenPixelsY(0)
    End With
End Function

Private Sub DrawCircle(Pt As POINTAPI)

    ScreenToClient Application.hwnd, Pt
    hdc = GetDC(Application.hwnd)
    With Pt
        hRoundRgn = CreateEllipticRgn(.x - 5, .y - 5, .x + 5, .y + 5)
    End With
    hBrush = CreateSolidBrush(vbRed)
    hBrush2 = CreateSolidBrush(vbBlack)
    SelectObject hdc, hBrush
    FillRgn hdc, hRoundRgn, hBrush
    FrameRgn hdc, hRoundRgn, hBrush2, 1, 1
    ReleaseDC Application.hwnd, hdc
    DeleteObject hBrush
    DeleteObject hBrush2
    DeleteObject hRoundRgn

End Sub

Private Sub ToggleVisibility(ByVal Shp As Shape)

    Dim i As Long
   
    For i = 1 To 2
        DoEvents
        Shp.Visible = Not Shp.Visible
        DoEvents
    Next i
End Sub


Class Usage example :

Put the following code in the ThisWorkbook Module to instantiate the Class:

VBA Code: 
Option Explicit

Private WithEvents Shapes As ShapesMoveEventClss

Private Sub Workbook_Activate()
    Set Shapes = New ShapesMoveEventClss
    Shapes.ApplyToSheet Sheet1
End Sub


'Shapes Move Pseudo-Event:
'========================
Private Sub Shapes_AfterDragOver _
( _
    ByVal DragedShape As Shape, _
    ByVal DropTarget As Object, _
    ByVal x As Single, _
    ByVal y As Single, _
    ByRef Cancel As Boolean _
)

    Dim sMsg As String, sDropTargetAddrOrName  As String
   
'    Is DropTarget a Range or Another Shape ?
    If TypeName(DropTarget) = "Range" Then
        sDropTargetAddrOrName = DropTarget.Address
    Else
        sDropTargetAddrOrName = DropTarget.Name
    End If
       
    'Set the 'Cancel' Arg to 'TRUE' to prevent 'SHAPE1' from being moved.
    If DragedShape.Name = "SHAPE1" Then Cancel = True
   
    'Display message to the user.
    sMsg = "  * Draged shape : (" & DragedShape.Name & ")" & vbNewLine & vbNewLine
    sMsg = sMsg & "  * New X Value := (" & x & " pt" & ")" & vbNewLine & vbNewLine
    sMsg = sMsg & "  * New Y Value := (" & y & " pt" & ")" & vbNewLine & vbNewLine
    sMsg = sMsg & "  * Drop Target : (" & sDropTargetAddrOrName & ")" & vbNewLine & vbNewLine
    sMsg = sMsg & "  * Cancel Move Opeartion : (" & Cancel & ")"
   
    MsgBox sMsg, vbInformation, "Shape Move Pseudo-Event."

End Sub
 
Last edited by a moderator:

Excel Facts

Do you hate GETPIVOTDATA?
Prevent GETPIVOTDATA. Select inside a PivotTable. In the Analyze tab of the ribbon, open the dropown next to Options and turn it off
Sort by date Sort by votes
Wow, thanks, I've learned a lot reading your code.

I did some experiments with your demo. I see the Drag&Drop applies only to shapes inside Sheet1 and I would need to make it more generic so it could work inside any active sheet. Unfortunately, all my attempts have failed so far.

Following your code, I saw that the targeted sheet is defined inside Private Sub Workbook_Activate(). The worksheet variable oSh is then declared and set inside ShapeMoveEventClss inside Public Sub ApplyToSheet.

I've tried to make oSh "Public" or "Dim" (instead of Private like you did in your code) but I get a "Variable not defined" when I run the code here under.

I have this code inside Sheet3 (where I previously Cut&Pasted all shapes already in Sheet1) :

Code: 
Sub Worksheet_Activate()
  ChangeSheet Sheet3
End Sub

which call this code inside Module1 (same result when this code is inside ShapeMoveEventClss)

Code: 
Sub ChangeSheet(ByVal Sh As Worksheet)
    Set oSh = Sh
End Sub

I've also tried with Dim oSh As Worksheet placed at the beginning of ThisWorkBook but I got the same error.

So, my question is how and where can I set oSh to be the current ActiveSheet whenever I change Sheet ?
 
Upvote 0
Hi xbricx,

I am glad you found the code useful.

The following should work for every shape in every worksheet of the workbook :

1- Class Code : (ShapesMoveEventClss)
VBA Code: 
Option Explicit

Private WithEvents CmbrsEvent As CommandBars

Private Type POINTAPI
    x As Long
    y As Long
End Type

#If VBA7 Then
    Private Declare PtrSafe Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
    Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hdc As LongPtr) As Long
    Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hdc As LongPtr, ByVal nIndex As Long) As Long
    Private Declare PtrSafe Function CreateEllipticRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As LongPtr
    Private Declare PtrSafe Function FillRgn Lib "gdi32" (ByVal hdc As LongPtr, ByVal hRgn As LongPtr, ByVal hBrush As LongPtr) As Long
    Private Declare PtrSafe Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As LongPtr
    Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hdc As LongPtr, ByVal hObject As LongPtr) As LongPtr
    Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
    Private Declare PtrSafe Function InvalidateRgn Lib "user32" (ByVal hwnd As LongPtr, ByVal hRgn As LongPtr, ByVal bErase As Long) As Long
    Private Declare PtrSafe Function ScreenToClient Lib "user32" (ByVal hwnd As LongPtr, lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Function FrameRgn Lib "gdi32" (ByVal hdc As LongPtr, ByVal hRgn As LongPtr, ByVal hBrush As LongPtr, ByVal nWidth As Long, ByVal nHeight As Long) As Long
   
    Private hRoundRgn As LongPtr, hdc As LongPtr, hBrush As LongPtr, hBrush2 As LongPtr
#Else
    Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
    Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
    Private Declare Function CreateEllipticRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
    Private Declare Function FillRgn Lib "gdi32" (ByVal hdc As Long, ByVal hRgn As Long, ByVal hBrush As Long) As Long
    Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
    Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
    Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
    Private Declare Function InvalidateRgn Lib "user32" (ByVal hwnd As Long, ByVal hRgn As Long, ByVal bErase As Long) As Long
    Private Declare Function ScreenToClient Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
    Private Declare Function FrameRgn Lib "gdi32" (ByVal hdc As Long, ByVal hRgn As Long, ByVal hBrush As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long

    Private hRoundRgn As Long, hdc As Long, hBrush As Long, hBrush2 As Long
#End If

Private Const LOGPIXELSX As Long = 88
Private Const LOGPIXELSY As Long = 90
Private Const POINTSPERINCH = 72

Private oSh As Worksheet
Private lTotalShapes As Long

Private Sub Class_Initialize()
    Call TagShapes
End Sub

Private Sub Class_Terminate()
    Set CmbrsEvent = Nothing
End Sub

Public Sub ApplyToSheet(ByVal Sh As Worksheet)
    Set oSh = Sh
End Sub

Private Sub CmbrsEvent_OnUpdate()
    Dim tCurPos As POINTAPI
    Dim tCenterShapePos As POINTAPI
    Dim oDropTarget As Object
    Dim bCancel As Boolean
    Dim oShape As Shape
    Dim sTagsArray() As String

    On Error Resume Next
   
    If Not (ActiveSheet Is oSh) Then Exit Sub
    If ActiveSheet.Shapes.Count <> lTotalShapes Then lTotalShapes = 0: Call TagShapes: Exit Sub
   
    Application.CommandBars.FindControl(ID:=2040).Enabled = Not Application.CommandBars.FindControl(ID:=2040).Enabled
   
    GetCursorPos tCurPos
    Set oShape = ActiveSheet.Shapes(ActiveWindow.RangeFromPoint(tCurPos.x, tCurPos.y).Name)
   
    If TypeName(oShape) <> "Range" Then
        sTagsArray = Split(oShape.AlternativeText, "*")
        If GetAsyncKeyState(VBA.vbKeyShift) Then
            oShape.Select
        End If
    End If
   
    With oShape
        .ZOrder msoBringToFront
        If sTagsArray(0) <> CStr(.Left) Or sTagsArray(1) <> CStr(.Top) Then
            tCenterShapePos = ShapeMiddlePTtoPX(oShape)
           
            ToggleVisibility oShape
            DoEvents
                .Visible = False
            DoEvents
            Set oDropTarget = ActiveWindow.RangeFromPoint(tCenterShapePos.x, tCenterShapePos.y)
            DoEvents
                .Visible = True
            DoEvents
   
            If TypeName(ActiveWindow.RangeFromPoint(tCurPos.x, tCurPos.y)) <> "Range" And _
            TypeName(ActiveWindow.RangeFromPoint(tCurPos.x, tCurPos.y)) <> "Nothing" Then
                DrawCircle tCenterShapePos
                Call ThisWorkbook.Shapes_AfterDragOver(oShape, oDropTarget, .Left, .Top, bCancel)
                InvalidateRgn Application.hwnd, hRoundRgn, 0
                ToggleVisibility oShape
                If bCancel Then .Left = sTagsArray(0): .Top = sTagsArray(1)
            End If
        DoEvents
        End If
        .AlternativeText = CStr(.Left) & "*" & CStr(.Top)
    End With     
End Sub

Private Sub TagShapes()
    Dim oShp As Shape
   
    For Each oShp In ActiveSheet.Shapes
        oShp.AlternativeText = CStr(oShp.Left) & "*" & CStr(oShp.Top)
        lTotalShapes = lTotalShapes + 1
    Next
    Set CmbrsEvent = Application.CommandBars
End Sub

Private Function ScreenDPI(bVert As Boolean) As Long
    Static lDPI(1), lDC
   
    If lDPI(0) = 0 Then
        lDC = GetDC(0)
        lDPI(0) = GetDeviceCaps(lDC, LOGPIXELSX)
        lDPI(1) = GetDeviceCaps(lDC, LOGPIXELSY)
        lDC = ReleaseDC(0, lDC)
    End If
    ScreenDPI = lDPI(Abs(bVert))
End Function
 
Private Function PTtoPX _
(Points As Double, bVert As Boolean) As Long
    PTtoPX = Points * ScreenDPI(bVert) / POINTSPERINCH
End Function

Private Function ShapeMiddlePTtoPX(ByVal Shp As Shape) As POINTAPI
    Dim OWnd  As Window
   
    Set OWnd = Shp.Parent.Parent.Windows(1)
    With Shp
        ShapeMiddlePTtoPX.x = PTtoPX((.Left + (.Width / 2)) * OWnd.Zoom / 100, 0) _
        + OWnd.PointsToScreenPixelsX(0)
        ShapeMiddlePTtoPX.y = PTtoPX((.Top + (.Height / 2)) * OWnd.Zoom / 100, 1) _
        + OWnd.PointsToScreenPixelsY(0)
    End With
End Function

Private Sub DrawCircle(Pt As POINTAPI)
    ScreenToClient Application.hwnd, Pt
    hdc = GetDC(Application.hwnd)
    With Pt
        hRoundRgn = CreateEllipticRgn(.x - 5, .y - 5, .x + 5, .y + 5)
    End With
    hBrush = CreateSolidBrush(vbRed)
    hBrush2 = CreateSolidBrush(vbBlack)
    SelectObject hdc, hBrush
    FillRgn hdc, hRoundRgn, hBrush
    FrameRgn hdc, hRoundRgn, hBrush2, 1, 1
    ReleaseDC Application.hwnd, hdc
    DeleteObject hBrush
    DeleteObject hBrush2
    DeleteObject hRoundRgn
End Sub

Private Sub ToggleVisibility(ByVal Shp As Shape)
    Dim i As Long
   
    For i = 1 To 2
        DoEvents
        Shp.Visible = Not Shp.Visible
        DoEvents
    Next i
End Sub
2- Code in ThisWorkbook Module:
VBA Code: 
Option Explicit

Private oCol As Collection

Private Sub Workbook_Activate()
Dim oShp As ShapesMoveEventClss, oWs As Worksheet

Set oCol = New Collection
    For Each oWs In ThisWorkbook.Worksheets
        Set oShp = New ShapesMoveEventClss
        oShp.ApplyToSheet oWs
        oCol.Add oShp
    Next
End Sub


'Shapes Move Pseudo-Event:
'========================
Public Sub Shapes_AfterDragOver _
( _
    ByVal DragedShape As Shape, _
    ByVal DropTarget As Object, _
    ByVal x As Single, _
    ByVal y As Single, _
    ByRef Cancel As Boolean _
)

    Dim sMsg As String, sDropTargetAddrOrName  As String
   
    'Is DropTarget a Range or Another Shape ?
    If TypeName(DropTarget) = "Range" Then
        sDropTargetAddrOrName = DropTarget.Address
    Else
        sDropTargetAddrOrName = DropTarget.Name
    End If
   
    'Set the 'Cancel' Arg to 'TRUE' to prevent 'SHAPE1' from being moved.
    If DragedShape.Name = "SHAPE1" Then Cancel = True
   
   'Display message to the user.
    sMsg = "  * Draged shape : (" & DragedShape.Name & ")" & vbNewLine & vbNewLine
    sMsg = sMsg & "  * Shape Parent Sheet : (" & DragedShape.Parent.Name & ")" & vbNewLine & vbNewLine
    sMsg = sMsg & "  * New X Value := (" & x & " pt" & ")" & vbNewLine & vbNewLine
    sMsg = sMsg & "  * New Y Value := (" & y & " pt" & ")" & vbNewLine & vbNewLine
    sMsg = sMsg & "  * Drop Target : (" & sDropTargetAddrOrName & ")" & vbNewLine & vbNewLine
    sMsg = sMsg & "  * Cancel Move Opeartion : (" & Cancel & ")"
   
    MsgBox sMsg, vbInformation, "Shape Move Pseudo-Event."
End Sub
 
Last edited by a moderator:
Upvote 0
Hello - I've played with the code and the demo and observed that the event was only triggered when the excel worksheet was opened on my main computer screen (I've got a second screen - when the worksheet is opened on this second screen, it doesn't display the new shape positions)
Any ideas about a quick fix?

By the way - very nice code! it helped me a lot!

Thank you
 
Upvote 0
LSA_1984 said:
Hello - I've played with the code and the demo and observed that the event was only triggered when the excel worksheet was opened on my main computer screen (I've got a second screen - when the worksheet is opened on this second screen, it doesn't display the new shape positions)
Any ideas about a quick fix?

By the way - very nice code! it helped me a lot!

Thank you
Click to expand...
Sorry but it is difficult for me to test as I only have one monitor.
Thanks.
 
Upvote 0
Hey Jaafar,

I used this code in one of my files. I didn't need any action on the shapes (I use them to arrange columns that I want in a filter). So I added one sub in a normal module, and used it for the OnAction that selects the shape. This eliminates the need to hold shift.

Settings is the codename of the worksheet.

VBA Code: 
Public Sub Shape_Click()

    Settings.Shapes(Application.Caller).Select

End Sub
 
Upvote 0
Hey Jafaar,
Very nice code. It would help me out I think but in my case, I'm using the shape property "AlternativeText" to store information I'm using for other purposes. I noticed that you are using this property too for the calculations, and it overwrites all my "AlternativeText". Is there another way to use this code and store the values you need for calculations in another property?
 
Upvote 0
karimania1984 said:
Hey Jafaar,
Very nice code. It would help me out I think but in my case, I'm using the shape property "AlternativeText" to store information I'm using for other purposes. I noticed that you are using this property too for the calculations, and it overwrites all my "AlternativeText". Is there another way to use this code and store the values you need for calculations in another property?
Click to expand...
What kind of shapes are you using?
I had a quick look, and what using about the Title property? Using Jaafar's demo workbook, I changed the SHAPE2 shape's title property to "THIS IS MY TEXT AND IT AIN'T GONNA CHANGE". Although it appears in the Alt Text pane (as below), VBA still treats this and the content of the AlternativeText property separately.

1694604158164.png


To demonstrate:
VBA Code: 
Sub AddTag()
    Dim shp As Shape
    Set shp = ActiveSheet.Shapes("SHAPE2")
    shp.Title = "THIS IS MY TEXT AND IT AIN'T GONNA CHANGE"
End Sub

Sub GetTag()
    Dim shp As Shape
    Set shp = ActiveSheet.Shapes("SHAPE2")
    Debug.Print shp.AlternativeText
    Debug.Print shp.Title
End Sub
Would that solve the problem?
 
Upvote 0
You must log in or register to reply here.

Similar threads

M
  • Question Question
Please help me to correct Excel VBA code!
Replies
1
Views
328
Minh Tuan VN
M
Jaafar Tribak
  • Question Question
KeyPress Event for Worksheet Cells (Subclassing Without Crashing)
Replies
0
Views
253
Jaafar Tribak
Jaafar Tribak
S
  • Solved
Hide userform title bar, and locking the userform into a relative position on the application.
2
Replies
16
Views
484
Jaafar Tribak
Jaafar Tribak
Jaafar Tribak
  • Question Question
Capturing the Paste Event (API Hooking - Redirection)
Replies
4
Views
791
Jaafar Tribak
Jaafar Tribak
T
  • Solved
Chart point must move to point of click in chart
Replies
2
Views
641
tigger_na
T

Forum statistics

Threads
1,223,898
Messages
6,175,272
Members
452,628
Latest member
dd2

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top