Jaafar Tribak
Well-known Member
- Joined
- Dec 5, 2002
- Messages
- 9,806
- Office Version
- 2016
- Platform
- 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:
Workbook Demo
Add a Class Module to your project and give it the name of ShapesMoveEventClss
Class Code :
Class Usage example :
Put the following code in the ThisWorkbook Module to instantiate the Class:
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: