Option Explicit
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL] VBA7 Then
Private Declare PtrSafe Function AccessibleChildren Lib "oleacc" (ByVal paccContainer As Office.IAccessible, ByVal iChildStart As Long, ByVal cChildren As Long, ByRef rgvarChildren As Any, ByRef pcObtained As Long) As Long
Private Declare PtrSafe Sub mouse_event Lib "user32" (ByVal dwFlags As Long, ByVal dx As Long, ByVal dy As Long, ByVal cButtons As Long, ByVal dwExtraInfo As LongPtr)
Private Declare PtrSafe Function GetFocus Lib "user32" () As LongPtr
Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
Private Declare PtrSafe Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
Private Proc1Addr As LongPtr, Proc2Addr As LongPtr
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL]
Private Declare Function AccessibleChildren Lib "oleacc" (ByVal paccContainer As Office.IAccessible, ByVal iChildStart As Long, ByVal cChildren As Long, ByRef rgvarChildren As Any, ByRef pcObtained As Long) As Long
Private Declare Sub mouse_event Lib "user32" (ByVal dwFlags As Long, ByVal dx As Long, ByVal dy As Long, ByVal cButtons As Long, ByVal dwExtraInfo As Long)
Private Declare Function GetFocus Lib "user32" () As Long
Private Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
Private Proc1Addr As Long, Proc2Addr As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL] If
Private Const MOUSEEVENTF_LEFTUP = &H4
Private bStatusBarHidden As Boolean
Sub StartTimer()
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL] VBA7 Then
Proc1Addr = VBA.CLngPtr(AddressOf StartWatching)
Proc2Addr = VBA.CLngPtr(AddressOf HandlePopupWindows)
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL]
Proc1Addr = VBA.CLng(AddressOf StartWatching)
Proc2Addr = VBA.CLng(AddressOf HandlePopupWindows)
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL] If
bStatusBarHidden = False
KillTimer Application.hwnd, 0
SetTimer Application.hwnd, 0, 0, AddressOf StartWatching
End Sub
Sub StopTimer()
KillTimer Application.hwnd, 0
If bStatusBarHidden Then Application.DisplayStatusBar = False
End Sub
Private Sub StartWatching()
Dim oIacc As Variant, i As Long, bCancel As Boolean
If Not ActiveWorkbook Is ThisWorkbook Then Exit Sub
Set oIacc = Application.CommandBars("Status Bar")
If oIacc.Visible Then
For i = 0 To 6
AccessibleChildren oIacc, IIf(i Mod 2 = 0, 0, 3), 1, oIacc, 1
Next i
If InStr(1, UCase(oIacc.accName(0&)), UCase("glisser")) Or InStr(1, UCase(oIacc.accName(0&)), UCase("Drag")) Then
KillTimer Application.hwnd, 0
SetTimer Application.hwnd, 0, 0, Proc2Addr
Call Cells_BeforeDragOver(ActiveWindow.RangeSelection, CBool(GetAsyncKeyState(vbKeyMenu)), _
CBool(GetAsyncKeyState(vbKeyControl)), CBool(GetAsyncKeyState(vbKeyShift)), bCancel)
If bCancel Then mouse_event MOUSEEVENTF_LEFTUP, 0, 0, 0, 0
SetTimer Application.hwnd, 0, 0, Proc1Addr
End If
Else
bStatusBarHidden = True
Application.DisplayStatusBar = True
End If
End Sub
Private Sub HandlePopupWindows()
KillTimer Application.hwnd, 0
If GetFocus <> Application.hwnd Then mouse_event MOUSEEVENTF_LEFTUP, 0, 0, 0, 0
End Sub
[B][COLOR=#006400]'****************************************************************[/COLOR][/B]
[B][COLOR=#006400]' Pseudo Event *[/COLOR][/B]
[B][COLOR=#006400]'****************************************************************[/COLOR][/B]
[B][COLOR=#006400]
[/COLOR][/B]
[B][COLOR=#006400]' Example : Cancel Dragging Cells in Column A[/COLOR][/B]
[B][COLOR=#006400]'--------------------------------------------[/COLOR][/B]
Private Sub Cells_BeforeDragOver( _
ByVal Target As Range, _
ByVal Alt As Boolean, _
ByVal Ctrl As Boolean, _
ByVal Shift As Boolean, _
ByRef Cancel As Boolean _
)
If Target.Column = 1 Then
MsgBox "Dragging Cells in Column:'A'" & vbNewLine & _
"is not allowed.", vbCritical
Cancel = True
End If
End Sub