Option Explicit
Private Type POINTAPI
X As Long
Y As Long
End Type
#If VBA7 Then
Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare PtrSafe Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
Private Declare PtrSafe Function SetCursorAPI Lib "user32" Alias "SetCursor" (ByVal hCursor As LongPtr) As LongPtr
Private Declare PtrSafe Function LoadCursor Lib "user32" Alias "LoadCursorA" (ByVal hInstance As LongPtr, ByVal lpCursorName As Long) As Long
Private Declare PtrSafe Function DestroyCursor Lib "user32" (ByVal hCursor As LongPtr) As Long
#Else
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
Private Declare Function SetCursorAPI Lib "user32" Alias "SetCursor" (ByVal hCursor As Long) As Long
Private Declare Function LoadCursor Lib "user32" Alias "LoadCursorA" (ByVal hInstance As Long, ByVal lpCursorName As Long) As Long
Private Declare Function DestroyCursor Lib "user32" (ByVal hCursor As Long) As Long
#End If
Private Sub Workbook_Open()
Call AssignGenericMacro
End Sub
Private Sub AssignGenericMacro()
Dim ws As Worksheet
Dim shp As Shape
For Each ws In ThisWorkbook.Worksheets
For Each shp In ws.Shapes
shp.OnAction = Me.CodeName & ".GenericMacro"
Next shp
Next ws
End Sub
Private Sub GenericMacro()
Const IDC_NO = 32646&
Static tInitPt As POINTAPI
#If Win64 Then
Dim hCursor As LongLong
#Else
Dim hCursor As Long
#End If
Dim tCurPt As POINTAPI
Dim t As Single, l As Single
l = ActiveSheet.Shapes(Application.Caller).Left
t = ActiveSheet.Shapes(Application.Caller).Top
hCursor = LoadCursor(0, IDC_NO)
Call GetCursorPos(tInitPt)
Do
Call GetCursorPos(tCurPt)
If tCurPt.X <> 0 And tCurPt.X <> tInitPt.X Then
If tCurPt.Y <> 0 And tCurPt.Y <> tInitPt.Y Then
Call SetCursorAPI(hCursor)
End If
End If
Loop Until GetAsyncKeyState(VBA.vbKeyLButton) = 0
Call DestroyCursor(hCursor)
With ActiveSheet.Shapes(Application.Caller)
.Left = ActiveWindow.RangeFromPoint(tCurPt.X, tCurPt.Y).Left
.Top = ActiveWindow.RangeFromPoint(tCurPt.X, tCurPt.Y).Top
'OPTIONAL FEEDBACK ... COMMENT OUT THE FOLLOWING LINES IF FEEDBACK NOT NEEDED.
If .Left = l And .Top = t Then
Application.OnTime Now, "'" & Me.CodeName & ".UserFeedBack """ & .Name & """ , TRUE '"
Else
Application.OnTime Now, "'" & Me.CodeName & ".UserFeedBack """ & .Name & """ , False '"
End If
End With
End Sub
Private Sub UserFeedBack(ByVal ShapeName As String, ByVal Click As Boolean)
MsgBox "You " & IIf(Click, "CLIKED", "MOVED") & " the Shape :" & vbNewLine & "[" & ShapeName & "]", vbInformation
End Sub