Jaafar Tribak
Well-known Member
- Joined
- Dec 5, 2002
- Messages
- 9,728
- Office Version
- 2016
- Platform
- Windows
Motivated by the question posted here , I have managed (I hope) to simulate a Before drop event for cells/ranges
Workbook Example
The signature of the pseudo event is written in line with the standard office events format for an easy and a more intuitive use .. setting the Cancel argument to True simply aborts the Drop operartion
Public Sub Cells_BeforeDrop _
(ByVal SourceRange As Range, ByVal DestRange As Range, ByRef Cancel As Boolean)
The above event handler procedure MUST reside in the ThisWorkbook module and MUST be Public
Known limitations:
1- Works only in 32bit systems ( code needs updating for 64bits)
2- Event doesn't work when dragging cells accross different workbooks and/or windows
3- Event doesn't fire when overriding existing data in the drop range (still working on this)
A Word Of Caution:
Because the code makes use of APIs and subclasses the CLIPBRDWNDCLASS window , any compile error inside the event procedure will crash excel ! .. so save your work often when editing/experimenting with the event code.
1- This code goes in a standard module :
2- This code goes in the ThisWorkbook module :
I have written and tested the code in xl2007 WinXP and works as expected
I would be grateful to hear from you any suggestions or problems encountered
Regards
Workbook Example
The signature of the pseudo event is written in line with the standard office events format for an easy and a more intuitive use .. setting the Cancel argument to True simply aborts the Drop operartion
Public Sub Cells_BeforeDrop _
(ByVal SourceRange As Range, ByVal DestRange As Range, ByRef Cancel As Boolean)
The above event handler procedure MUST reside in the ThisWorkbook module and MUST be Public
Known limitations:
1- Works only in 32bit systems ( code needs updating for 64bits)
2- Event doesn't work when dragging cells accross different workbooks and/or windows
3- Event doesn't fire when overriding existing data in the drop range (still working on this)
A Word Of Caution:
Because the code makes use of APIs and subclasses the CLIPBRDWNDCLASS window , any compile error inside the event procedure will crash excel ! .. so save your work often when editing/experimenting with the event code.
1- This code goes in a standard module :
Code:
Option Explicit
Private Type POINTAPI
X As Long
Y As Long
End Type
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Declare Function FindWindow Lib "user32" _
Alias "FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" _
(ByVal hWnd1 As Long, ByVal hWnd2 As Long, _
ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Private Declare Function IsWindowVisible Lib "user32" _
(ByVal hwnd As Long) As Long
Private Declare Function SetWindowLong Lib "user32" _
Alias "SetWindowLongA" _
(ByVal hwnd As Long, _
ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long
Private Declare Function CallWindowProc Lib "user32" _
Alias "CallWindowProcA" _
(ByVal lpPrevWndFunc As Long, _
ByVal hwnd As Long, _
ByVal Msg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long
Private Declare Function SendMessage Lib "user32" _
Alias "SendMessageA" _
(ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
lParam As Any) As Long
Private Declare Function SetProp Lib "user32" Alias "SetPropA" _
(ByVal hwnd As Long, _
ByVal lpString As String, _
ByVal hData As Long) As Long
Private Declare Function RemoveProp Lib "user32" Alias "RemovePropA" _
(ByVal hwnd As Long, _
ByVal lpString As String) As Long
Private Declare Function GetProp Lib "user32" Alias "GetPropA" _
(ByVal hwnd As Long, _
ByVal lpString As String) As Long
Private Declare Function GetCursorPos Lib "user32" _
(lpPoint As POINTAPI) 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 GetDC Lib "user32" _
(ByVal hwnd As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" _
(ByVal hdc As Long, _
ByVal nIndex As Long) As Long
Private Declare Function ReleaseDC Lib "user32" _
(ByVal hwnd As Long, _
ByVal hdc As Long) As Long
Private Declare Sub ClipCursor Lib "user32" (lpRect As Any)
Private Declare Function InvalidateRect Lib "User32.dll" _
(ByVal hwnd As Long, _
ByVal lpRect As Long, _
ByVal bErase As Long) As Long
Private Declare Function GetSystemMetrics Lib "user32" _
(ByVal nIndex As Long) As Long
Private Const LOGPIXELSX As Long = 88
Private Const LOGPIXELSY As Long = 90
Private Const PointsPerInch = 72
Private Const WM_SETREDRAW = &HB
Private Const SM_CXSCREEN = 0
Private Const SM_CYSCREEN = 1
Private Const WM_DESTROYCLIPBOARD = &H307
Private Const GWL_WNDPROC As Long = (-4)
Private RowOffset As Long
Private ColOffset As Long
Sub Start_Drag_And_Drop_Hook()
Dim oldProcAddr As Long
Dim lClipBrdWndHwnd As Long
Dim Wbhwnd As Long
If GetProp(Application.hwnd, "oldProcAddr") = 0 Then
SetTimer Application.hwnd, 0, 1, AddressOf TimerProc
Wbhwnd = FindWindowEx(Application.hwnd, 0, "XLDESK", vbNullString)
Wbhwnd = FindWindowEx(Wbhwnd, 0, "EXCEL7", vbNullString)
SetProp Application.hwnd, "WbHwnd", Wbhwnd
lClipBrdWndHwnd = FindWindow("CLIPBRDWNDCLASS", vbNullString)
SetProp Application.hwnd, "ClipBrdHwnd", lClipBrdWndHwnd
oldProcAddr = SetWindowLong _
(lClipBrdWndHwnd, GWL_WNDPROC, AddressOf WindowProc)
SetProp Application.hwnd, "oldProcAddr", oldProcAddr
End If
End Sub
Sub Stop_Drag_And_Drop_Hook()
SetWindowLong GetProp(Application.hwnd, "ClipBrdHwnd"), _
GWL_WNDPROC, GetProp(Application.hwnd, "oldProcAddr")
KillTimer Application.hwnd, 0
RemoveProp Application.hwnd, "oldProcAddr"
RemoveProp Application.hwnd, "ClipBrdHwnd"
RemoveProp Application.hwnd, "WbHwnd"
RemoveProp Application.hwnd, "EXCELF"
RemoveProp Application.hwnd, "EXCELFvisible"
End Sub
Private Function WindowProc _
(ByVal hwnd As Long, ByVal uMsg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long
Dim tMousePtr As POINTAPI
Dim oDropRange As Range
Dim bCancel As Boolean
On Error Resume Next
If Application.CutCopyMode = False Then Exit Function
Select Case uMsg
Case WM_DESTROYCLIPBOARD
If CBool(GetProp(Application.hwnd, "EXCELFvisible")) Then
GetCursorPos tMousePtr
Set oDropRange = ActiveWindow.RangeFromPoint(tMousePtr.X, tMousePtr.Y)
With oDropRange
If .Column <= ColOffset Then
Set oDropRange = Range(Cells(.Row - RowOffset, 1), _
Cells(.Row + (Selection.Rows.Count - RowOffset) - 1, Selection.Columns.Count))
End If
If .Row <= RowOffset Then
Set oDropRange = Range(Cells(1, .Column - ColOffset), _
Cells(Selection.Rows.Count, .Column + (Selection.Columns.Count - ColOffset) - 1))
End If
If .Column <= ColOffset And .Row <= RowOffset Then
Set oDropRange = Range(Cells(1, 1), _
Cells(Selection.Rows.Count, Selection.Columns.Count))
End If
Set oDropRange = _
.Offset(-RowOffset, -ColOffset).Resize(Selection.Rows.Count, Selection.Columns.Count)
End With
Call ThisWorkbook.Cells_BeforeDrop(Selection, oDropRange, bCancel)
If bCancel Then
Call SendMessage(GetProp(Application.hwnd, "WbHwnd"), WM_SETREDRAW, False, 0&)
Application.EnableEvents = False
SetTimer GetProp(Application.hwnd, "ClipBrdHwnd"), 0, 1, AddressOf Undo
Else
Application.EnableEvents = True
End If
End If
End Select
WindowProc = CallWindowProc _
(GetProp(Application.hwnd, "oldProcAddr"), hwnd, uMsg, wParam, lParam)
End Function
Private Sub Undo()
On Error Resume Next
KillTimer GetProp(Application.hwnd, "ClipBrdHwnd"), 0
Application.Undo
Application.EnableEvents = True
Call SendMessage(GetProp(Application.hwnd, "WbHwnd"), WM_SETREDRAW, True, 0&)
InvalidateRect GetProp(Application.hwnd, "WbHwnd"), 0, 0
End Sub
Private Sub TimerProc()
Dim tMousePtr As POINTAPI
Dim tWbScreenArea As RECT
Static tTopLeftCell As RECT
Dim EXCELFhwnd As Long
Dim SelRow As Long, selCol As Long
Dim RangeUnderMouseCol As Long, RangeUnderMouseRow As Long
Dim oDropRange As Range
Dim bIsEXCELFvisible As Boolean
On Error Resume Next
SelRow = Selection.Row: selCol = Selection.Column
GetCursorPos tMousePtr
Set oDropRange = ActiveWindow.RangeFromPoint(tMousePtr.X, tMousePtr.Y)
With oDropRange
RangeUnderMouseCol = .Column
RangeUnderMouseRow = .Row
If .Row < SelRow Then SelRow = SelRow - 1
If .Row > Selection.Rows.Count + SelRow - 1 Then SelRow = SelRow + 1
If .Column < selCol Then selCol = selCol - 1
If .Column > Selection.Columns.Count + selCol - 1 Then selCol = selCol + 1
RowOffset = .Row - SelRow
ColOffset = .Column - selCol
End With
tTopLeftCell = GetRangeRect(ActiveWindow.VisibleRange.Cells(1, 1))
With tWbScreenArea
.Left = tTopLeftCell.Left
.Top = tTopLeftCell.Top
.Right = GetSystemMetrics(SM_CXSCREEN)
.Bottom = GetSystemMetrics(SM_CYSCREEN)
End With
EXCELFhwnd = FindWindow("EXCELF", vbNullString)
SetProp Application.hwnd, "EXCELF", EXCELFhwnd
SetProp Application.hwnd, "EXCELFvisible", IsWindowVisible(EXCELFhwnd)
If IsWindowVisible(EXCELFhwnd) Then ClipCursor tWbScreenArea Else ClipCursor ByVal 0
End Sub
Private Function GetRangeRect(ByVal rng As Range) As RECT
Dim OWnd As Window
Set OWnd = rng.Parent.Parent.Windows(1)
With rng
GetRangeRect.Left = PTtoPX(.Left * OWnd.Zoom / 100, 0) _
+ OWnd.PointsToScreenPixelsX(0)
GetRangeRect.Top = PTtoPX(.Top * OWnd.Zoom / 100, 1) _
+ OWnd.PointsToScreenPixelsY(0)
GetRangeRect.Right = PTtoPX(.Width * OWnd.Zoom / 100, 0) _
+ GetRangeRect.Left
GetRangeRect.Bottom = PTtoPX(.Height * OWnd.Zoom / 100, 1) _
+ GetRangeRect.Top
End With
End Function
Private Function PTtoPX _
(Points As Long, bVert As Boolean) As Long
PTtoPX = Points * ScreenDPI(bVert) / PointsPerInch
End Function
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 Function2- This code goes in the ThisWorkbook module :
Code:
Option Explicit
Private Sub Workbook_Open()
Call Start_Drag_And_Drop_Hook
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
[COLOR=#008000]'Caution: Not stopping the hook before closing will crash the application ![/COLOR]
Call Stop_Drag_And_Drop_Hook
End Sub
[COLOR=#008000]'********************************************************
'Pseudo-Event to intercept cell drag and drop operations
'CAUTION : Any compiler error will crash the application !
'*********************************************************[/COLOR]
Public Sub Cells_BeforeDrop _
(ByVal SourceRange As Range, ByVal DestRange As Range, ByRef Cancel As Boolean)
Dim sPromptMsg1 As String
Dim sPromptMsg2 As String
Dim sPromptMsg3 As String
On Error GoTo Oops
sPromptMsg1 = "You are about to drop the range : '"
sPromptMsg2 = "onto the range : '"
sPromptMsg3 = "Go ahead ? "
If MsgBox(sPromptMsg1 & "'" & SourceRange.Address & "'" & vbCrLf & _
sPromptMsg2 & DestRange.Address & "'" & vbCrLf & vbCrLf & sPromptMsg3, _
vbYesNo + vbExclamation, "Before Drop Event") = vbNo Then
Cancel = True
End If
Exit Sub
Oops:
MsgBox Err.Description
End SubI have written and tested the code in xl2007 WinXP and works as expected
I would be grateful to hear from you any suggestions or problems encountered
Regards
