Option Explicit
Type POINTAPI
X As Long
Y As Long
End Type
#If VBA7 Then
#If Win64 Then
Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
Declare PtrSafe Function DragDetect Lib "user32" (ByVal hWnd As LongPtr, ByVal pt As LongLong) As Long
#Else
Declare PtrSafe Function DragDetect Lib "user32.DLL" (ByVal hWnd As LongPtr, pt As POINTAPI) As Long
#End If
Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Declare PtrSafe Function SetTimer Lib "user32" (ByVal hWnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
Declare PtrSafe Function KillTimer Lib "user32" (ByVal hWnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
Declare PtrSafe Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As LongPtr)
Declare PtrSafe Function GetCursorPos Lib "user32.DLL" (lpPoint As POINTAPI) As Long
Declare PtrSafe Function GetActiveWindow Lib "user32" () As LongPtr
Declare PtrSafe Function AccessibleChildren Lib "oleacc" (ByVal paccContainer As Any, ByVal iChildStart As Long, ByVal cChildren As Long, ByRef rgvarChildren As Any, ByRef pcObtained As Long) As Long
#Else
Declare Function DragDetect Lib "user32.DLL" (ByVal hWnd As Long, pt As POINTAPI) As Long
Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Declare Function SetTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Declare Function KillTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long) As Long
Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Declare Function GetCursorPos Lib "user32.DLL" (lpPoint As POINTAPI) As Long
Declare Function GetActiveWindow Lib "user32" () As Long
Declare Function AccessibleChildren Lib "oleacc" (ByVal paccContainer As Any, ByVal iChildStart As Long, ByVal cChildren As Long, ByRef rgvarChildren As Any, ByRef pcObtained As Long) As Long
#End If
Sub StartTest()
ModifyCellDrag = True
End Sub
Sub StopTest()
ModifyCellDrag = False
End Sub
Property Let ModifyCellDrag(ByVal Modify As Boolean)
KillTimer Application.hWnd, 0
If Modify Then
SetTimer Application.hWnd, 0, 0, AddressOf MonitorMouseDragging
End If
End Property
Private Sub MonitorMouseDragging()
Const KEYEVENTF_KEYUP = &H2
Const VK_LSHIFT = &HA0
Const CHILDID_SELF = 0&
Const NAVDIR_FIRSTCHILD = &H7
Dim tCurPos As POINTAPI
Dim oIacc As IAccessible, vAcc As Variant, i As Long
'Stop Timer if inside the VBE to avoid potential problems !
If IsVBEActive Then
keybd_event VK_LSHIFT, 0, KEYEVENTF_KEYUP, 0
KillTimer Application.hWnd, 0
Exit Sub
End If
If GetActiveWindow = Application.hWnd Then
Set vAcc = Application.CommandBars("status Bar")
Set oIacc = vAcc.accNavigate(NAVDIR_FIRSTCHILD, CHILDID_SELF)
For i = 1 To 6
Set oIacc = oIacc.accNavigate(NAVDIR_FIRSTCHILD, CHILDID_SELF)
Next
GetCursorPos tCurPos
#If Win64 Then
Dim lPt As LongPtr
CopyMemory lPt, tCurPos, LenB(lPt)
If DragDetect(Application.hWnd, lPt) = 1 Then
#Else
If DragDetect(Application.hWnd, tCurPos) = 1 Then
#End If
If InStr(1, oIacc.accName(0&), "Drag to move", vbTextCompare) Then
keybd_event VK_LSHIFT, 0, 0, 0
End If
Else
keybd_event VK_LSHIFT, 0, KEYEVENTF_KEYUP, 0
End If
End If
End Sub
Private Function IsVBEActive() As Boolean
IsVBEActive = CBool(GetActiveWindow = FindWindow("wndclass_desked_gsk", vbNullString))
End Function
Private Sub Auto_Close()
ModifyCellDrag = False
End Sub
