Option Explicit
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _
(ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetClipboardData Lib "user32" _
(ByVal wFormat As Integer) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" _
(PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, _
IPic As IPicture) As Long
'\\ Declare a UDT to store a GUID for the IPicture OLE Interface
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
'\\ Declare a UDT to store the bitmap information
Private Type uPicDesc
Size As Long
Type As Long
hPic As Long
hPal As Long
End Type
Private Type POINTAPI
x As Long
y As Long
End Type
Private Const CF_BITMAP = 2
Private Const PICTYPE_BITMAP = 1
Private Const GWL_HINSTANCE = (-6)
'_______________________________________________________________
Private Declare Function SetWindowsHookEx Lib _
"user32" Alias "SetWindowsHookExA" _
(ByVal idHook As Long, ByVal lpfn As Long, _
ByVal hmod As Long, ByVal dwThreadId As Long) As Long
Private Declare Function CallNextHookEx Lib "user32" _
(ByVal hHook As Long, ByVal nCode As Long, _
ByVal wParam As Long, lParam As Any) As Long
Private Declare Function UnhookWindowsHookEx Lib "user32" _
(ByVal hHook As Long) As Long
Private Const HC_ACTION = 0
Private Const WH_MOUSE_LL = 14
Private Const WM_MOUSEMOVE = &H200
Private Const WM_LBUTTONUP = &H202
Private Const WM_LBUTTONDOWN = &H201
Private hhkLowLevelMouse As Long
Private blnHookEnabled As Boolean
Private udtCursorPos As POINTAPI
Private bButtonDown As Boolean
Private bFirstMouseMove As Boolean
Sub EnableDrag_Drop()
Sheets("Sheet1").Range("G1:H1").Interior.ColorIndex = 3
Sheets("Sheet1").Range("G1").Value = "Drag&Drop Mode is : ON"
Sheets("Sheet1").Range("G1").Font.ColorIndex = 2
Call Hook_Mouse
End Sub
Sub DisableDrag_Drop()
Sheets("Sheet1").Range("G1:H1").Interior.ColorIndex = 1
Sheets("Sheet1").Range("G1").Value = "Drag&Drop Mode is : OFF"
Sheets("Sheet1").Range("G1").Font.ColorIndex = 2
'reset cursor to normal
Application.Cursor = xlDefault
'reset the interactive prop here as safety net
Application.Interactive = True
' remove hook
Call UnHook_Mouse
'refresh our range
Application.CutCopyMode = False
End Sub
Private Sub Hook_Mouse()
' Prevent Hooking more than once
If blnHookEnabled = False Then
hhkLowLevelMouse = SetWindowsHookEx _
(WH_MOUSE_LL, AddressOf LowLevelMouseProc, GetAppInstance, 0)
' set flag
blnHookEnabled = True
End If
End Sub
Private Sub UnHook_Mouse()
If hhkLowLevelMouse <> 0 Then UnhookWindowsHookEx hhkLowLevelMouse
'reset Flag
blnHookEnabled = False
End Sub
Private Function LowLevelMouseProc _
(ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Static oCellToDrag As Range
Static dPosX As Double
Static dPosY As Double
Static dOldPosX As Double
Static dOldPosY As Double
Static TopLeftCell As Range
Static CellToDrag As Range
Static oldRange As Range
'Prevent crashing XL in case of unhandled errors !!!!!!!
On Error Resume Next
If (nCode = HC_ACTION) Then
GetCursorPos udtCursorPos
' store the cell under the mouse pointer
Set oCellToDrag = _
ActiveWindow.RangeFromPoint(udtCursorPos.x, udtCursorPos.y)
' wParam holds the mouse current status
Select Case wParam
'**********************************************************
Case Is = WM_LBUTTONDOWN
'allow cell dragging in columns A:B only
If Not IsCellWithinRange(oCellToDrag, Columns("a:b")) Then
Exit Function
End If
'set flag
bFirstMouseMove = True
' set flag
bButtonDown = True
'store the cell being dragged in a static var
Set CellToDrag = oCellToDrag
' as soon as the mouse left button is pressed
' take a snapshot of the cell under the mouse pointer
' and show the image control pop up
' this fires before the sheet selection event
SaveRangePic oCellToDrag, "C:\MyRangePic.bmp"
With Sheets("Sheet1").Image1
.Picture = LoadPicture("C:\MyRangePic.bmp")
.AutoSize = True
.Left = RangeUnderMouse.Left
.Top = RangeUnderMouse.Top
.Visible = False
End With
'cleanup file
Kill "C:\MyRangePic.bmp"
'**********************************************************
Case Is = WM_LBUTTONUP
' reset flag
bButtonDown = False
' avoid too much screen flickering
Application.ScreenUpdating = False
If Sheets("Sheet1").Image1.Visible Then
'are we dragging within columns A:B ?
If IsCellWithinRange(ByVal oCellToDrag, Columns("a:b")) And _
IsCellWithinRange(ByVal TopLeftCell, Columns("a:b")) Then
'if so, let's do the actual cells drag&drop here
TopLeftCell.Insert Shift:=xlDown
CellToDrag.Copy Destination:=TopLeftCell.Offset(-1)
'CellToDrag.Delete xlUp
Else
'if outside our dragging range stop and alert the user
Beep
Call UnHook_Mouse
MsgBox _
"Drag & Drop is only allowed between Columns A and B ! ", vbCritical
Call Hook_Mouse
End If
End If
'hide the image contrl until the next drag operation
Sheets("Sheet1").Image1.Visible = False
'**************************************************************
Case Is = WM_MOUSEMOVE
'block any interaction with XL while dragging the image contrl
'over our drag&drop range to avoid unwanted selection of underlying cells
If Union(oCellToDrag, Columns("a:b")).Address <> _
Union(oldRange, Columns("a:b")).Address Then
If Not IsCellWithinRange(RangeUnderMouse, Columns("a:b")) Or _
RangeUnderMouse Is Nothing Then
Application.Cursor = xlDefault
Application.Interactive = True
Else
'restore cursor and user interactivity if mouse
'outside our Drag&Drop range
Application.Cursor = xlNorthwestArrow
Application.Interactive = False
End If
End If
'store cell being dragged
Set oldRange = oCellToDrag
' convert pixels to points
dPosX = udtCursorPos.x * 0.75
dPosY = udtCursorPos.y * 0.75
'see if the mouse is moving while the left button is held down
'ie: see if dragging is underway
If bButtonDown Then
If bFirstMouseMove Then
Sheets("Sheet1").Image1.Visible = True
'reset flag
bFirstMouseMove = False
End If
'now, adjust the pos of the image cntrl to follow
'the moving mouse pointer
With Sheets("Sheet1").Image1
.Left = (.Left) - (dOldPosX - dPosX)
.Top = (.Top) - (dOldPosY - dPosY)
End With
Set TopLeftCell = Sheets("Sheet1").Image1.TopLeftCell
End If
' store previous mouse pos
dOldPosX = dPosX
dOldPosY = dPosY
End Select
End If
'Call next hook if any
LowLevelMouseProc = CallNextHookEx(0, nCode, wParam, ByVal lParam)
End Function
Private Sub SaveRangePic(ByVal SourceRange As Range, FilePathName As String)
Dim IID_IDispatch As GUID
Dim uPicinfo As uPicDesc
Dim IPic As IPicture
Dim hPtr As Long
'Copy Range to ClipBoard
SourceRange.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
OpenClipboard 0
hPtr = GetClipboardData(CF_BITMAP)
CloseClipboard
'Create the interface GUID for the picture
With IID_IDispatch
.Data1 = &H7BF80980
.Data2 = &HBF32
.Data3 = &H101A
.Data4(0) = &H8B
.Data4(1) = &HBB
.Data4(2) = &H0
.Data4(3) = &HAA
.Data4(4) = &H0
.Data4(5) = &H30
.Data4(6) = &HC
.Data4(7) = &HAB
End With
'Fill uPicInfo with necessary parts.
With uPicinfo
.Size = Len(uPicinfo) '\\ Length of structure.
.Type = PICTYPE_BITMAP '\\ Type of Picture
.hPic = hPtr '\\ Handle to image.
.hPal = 0 '\\ Handle to palette (if bitmap).
End With
'Create the Range Picture Object
OleCreatePictureIndirect uPicinfo, IID_IDispatch, True, IPic
'Save Picture Object
stdole.SavePicture IPic, FilePathName
End Sub
Private Function IsCellWithinRange(ByVal Cell As Range, Parent_Range As Range) As Boolean
IsCellWithinRange = (Union(Cell, Parent_Range).Address = Parent_Range.Address)
End Function
Private Function RangeUnderMouse() As Range
Dim udtP As POINTAPI
On Error Resume Next
GetCursorPos udtP
Set RangeUnderMouse = ActiveWindow.RangeFromPoint(udtP.x, udtP.y)
End Function
Private Function GetAppHwnd() As Long
'function needed for XL versions < 2000
GetAppHwnd = FindWindow("XLMAIN", Application.Caption)
End Function
Private Function GetAppInstance() As Long
'function needed for XL versions < 2000
GetAppInstance = GetWindowLong(GetAppHwnd, GWL_HINSTANCE)
End Function
