Option Explicit
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 Const CF_BITMAP = 2
Private Const PICTYPE_BITMAP = 1
'______________________________________________________________________________
Private Declare Function ClipCursor Lib "user32" (lpRect As Any) As Long
Private Declare Sub ClipCursorClear Lib "user32" _
Alias "ClipCursor" _
(ByVal lpRect As Long)
Private Declare Function GetDeviceCaps Lib "gdi32" ( _
ByVal hDC As Long, ByVal nIndex As Long) As Long
Private Declare Function GetDC Lib "user32" ( _
ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" ( _
ByVal hwnd As Long, ByVal hDC As Long) As Long
Private Const LOGPIXELSX As Long = 88
Private Const LOGPIXELSY As Long = 90
Private Const PointsPerInch = 72
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 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 Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) 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
Sub EnableDrag_Drop()
'change cursor to look like in drag&drop mode
Application.Cursor = xlNorthwestArrow
Call Hook_Mouse
End Sub
Sub DisableDrag_Drop()
'reset cursor to normal
Application.Cursor = xlDefault
' reset mouse default
Call UnHook_Mouse
Range("BB1:BC20").Copy Range("A1")
Rows("21:1000").Delete Shift:=xlUp
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, Application.Hinstance, 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
'Prevent crashing XL in case of unhandled errors !!!!!!!
On Error Resume Next
If (nCode = HC_ACTION) Then
'when Mouse is moved
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
' set this flag
bButtonDown = True
' 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(1).Image1
.Visible = True
.Picture = LoadPicture("C:\MyRangePic.bmp")
.AutoSize = True
.Left = ActiveWindow.RangeFromPoint(udtCursorPos.x, udtCursorPos.y).Left
.Top = ActiveWindow.RangeFromPoint(udtCursorPos.x, udtCursorPos.y).Top
End With
'cleanup file
Kill "C:\MyRangePic.bmp"
'**********************************************************
Case Is = WM_LBUTTONUP
' reset flag
bButtonDown = False
' avoid too much screen flickering
Application.ScreenUpdating = False
' after the drop operation is over
' we no longer need any cursor restriction
ClipCursorClear 0
Sheets(1).Unprotect
' do the actual cells drag&drop here
Sheets(1).Image1.TopLeftCell.Insert Shift:=xlDown
oCellToDrag.Copy Destination:=Sheets(1).Image1.TopLeftCell.Offset(-1)
oCellToDrag.Delete xlUp
' drog&drop over so hide the image control
Sheets(1).Image1.Visible = False
'**************************************************************
Case Is = WM_MOUSEMOVE
' convert pixels to points
dPosX = udtCursorPos.x * 0.75
dPosY = udtCursorPos.y * 0.75
' do nothing if mouse outside our named ranges : "RangeA" and "RangeB"
' note that "RangeA" and "RangeB" are Columns A and B of Sheets(1)
If IsCellWithinRange(Sheets(1).Image1.TopLeftCell, Range("RangeA")) _
Or IsCellWithinRange(Sheets(1).Image1.TopLeftCell, Range("RangeB")) Then
'see if the mouse is moving while the left button is held down
'ie: see if dragging is underway
If bButtonDown Then
' if so,temporarly protect sheet
' this is to avoid unwanted selection of ceels while dragging is under way
With Sheets(1)
.EnableSelection = xlNoSelection
.Protect Contents:=True, UserInterfaceOnly:=True
End With
' now, adjust the pos of the image cntrl to follow the moving mouse pointer
With Sheets(1).Image1
.Left = (.Left) - (dOldPosX - dPosX)
.Top = (.Top) - (dOldPosY - dPosY)
End With
' this is to cater for fast dragging !
RestrictCursorToControl Sheets(1).Image1
End If
Else
' if the mouse pointer is outside our named range hide image ctrl
Sheets(1).Image1.Visible = False
Sheets(1).Unprotect
End If
' store previous mouse pos
dOldPosX = dPosX
dOldPosY = dPosY
End Select
Exit Function
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 Sub RestrictCursorToControl(oControl As Object)
Dim uRect As RECT
Dim lhDC As Long
lhDC = GetDC(0)
With uRect
.Left = ActiveWindow.PointsToScreenPixelsX(oControl.Left * _
(GetDeviceCaps(lhDC, LOGPIXELSX) / PointsPerInch * (ActiveWindow.Zoom / 100)))
.Top = ActiveWindow.PointsToScreenPixelsY(oControl.Top * _
(GetDeviceCaps(lhDC, LOGPIXELSY) / PointsPerInch * (ActiveWindow.Zoom / 100)))
.Right = ActiveWindow.PointsToScreenPixelsX((oControl.Left + oControl.Width) * _
(GetDeviceCaps(lhDC, LOGPIXELSX) / PointsPerInch * (ActiveWindow.Zoom / 100)))
.Bottom = ActiveWindow.PointsToScreenPixelsY((oControl.Top + oControl.Height) * _
(GetDeviceCaps(lhDC, LOGPIXELSY) / PointsPerInch * (ActiveWindow.Zoom / 100))) - 1
End With
ClipCursor uRect
ReleaseDC 0, lhDC
End Sub
Private Function IsCellWithinRange(Cell As Range, Parent_Range As Range) As Boolean
IsCellWithinRange = (Union(Cell, Parent_Range).Address = Parent_Range.Address)
End Function
