Challenging Post - Override cell drag & drop behavior

[Legacy 98055]

For example. Dragging c7 to e5.

My range before dragging and dropping...

After the drop.

What do you think? I think it can be done but do not want to waste time going about it the wrong way. Please give me any ideas on how you would approach this problem.

Some information to start with. The modal dialog that pops up can be dealt with.

This one.

I can determine if I want to insert down or up. I am not concerned with shifting left or right at this point.

I can also determine the original address and destination address of the drag and drop operation by using the change event.

The ranges being dragged will be limited to a single cell.

Do you have any other suggestions?

I appreciate the input.

 

[Legacy 98055]

Jaafar.

I added a very basic mouse hook and it works ok. The only problem is the hook is not being unhooked when the dragdropper object is destroyed. The hook code is in module2 and is very basic. I need only be concerned with mousedown messages.


WARNING: This file contains code that will absolutely crash Excel.
Removed: DragDrop4.zip

Thanks...

Module2 code:
<table width="100%" border="1" bgcolor="White" style="filterrogid:DXImageTransform.Microsoft.Gradient(endColorstr='#C0CFE2', startColorstr='#FFFFFF', gradientType='0');"><tr><TD><font size="2" face=Courier New>  <font color="#0000A0">Option</font> <font color="#0000A0">Explicit</font>

  <font color="#0000A0">Private</font> <font color="#0000A0">Declare</font> <font color="#0000A0">Function</font> SetWindowsHookEx <font color="#0000A0">Lib</font> "user32" <font color="#0000A0">Alias</font> "SetWindowsHookExA" (ByVal idHook <font color="#0000A0">As</font> Long, <font color="#0000A0">ByVal</font> lpfn <font color="#0000A0">As</font> Long, <font color="#0000A0">ByVal</font> hmod <font color="#0000A0">As</font> Long, <font color="#0000A0">ByVal</font> dwThreadId <font color="#0000A0">As</font> Long) <font color="#0000A0">As</font> <font color="#0000A0">Long</font>
  <font color="#0000A0">Private</font> <font color="#0000A0">Declare</font> <font color="#0000A0">Function</font> UnhookWindowsHookEx <font color="#0000A0">Lib</font> "user32" (ByVal hHook <font color="#0000A0">As</font> Long) <font color="#0000A0">As</font> <font color="#0000A0">Long</font>
  <font color="#0000A0">Private</font> <font color="#0000A0">Declare</font> <font color="#0000A0">Function</font> CallNextHookEx <font color="#0000A0">Lib</font> "user32" (ByVal hHook <font color="#0000A0">As</font> Long, <font color="#0000A0">ByVal</font> ncode <font color="#0000A0">As</font> Long, <font color="#0000A0">ByVal</font> wParam <font color="#0000A0">As</font> Long, lParam <font color="#0000A0">As</font> Any) <font color="#0000A0">As</font> <font color="#0000A0">Long</font>

  <font color="#0000A0">Private</font> <font color="#0000A0">Const</font> WH_MOUSE_LL <font color="#0000A0">As</font> <font color="#0000A0">Long</font> = 14
  <font color="#0000A0">Private</font> <font color="#0000A0">Const</font> WM_LBUTTONDOWN <font color="#0000A0">As</font> <font color="#0000A0">Long</font> = &H201

  <font color="#0000A0">Private</font> hHook <font color="#0000A0">As</font> <font color="#0000A0">Long</font>
  <font color="#0000A0">Private</font> pDragDropperCBRef <font color="#0000A0">As</font> DragDropper

  <font color="#0000A0">Sub</font> DragDropperMouseHookUtility(DragDropperCBRef <font color="#0000A0">As</font> DragDropper)
       <font color="#0000A0">Set</font> pDragDropperCBRef = DragDropperCBRef
       hHook = SetWindowsHookEx(WH_MOUSE_LL, <font color="#0000A0">AddressOf</font> LowLevelMouseProc, Application.Hinstance, 0)
  <font color="#0000A0">End</font> <font color="#0000A0">Sub</font>

  <font color="#0000A0">Sub</font> StopHooking()
       <font color="#0000A0">Set</font> pDragDropperCBRef = <font color="#0000A0">Nothing</font>
       UnhookWindowsHookEx hHook
  <font color="#0000A0">End</font> <font color="#0000A0">Sub</font>


  <font color="#0000A0">Public</font> <font color="#0000A0">Function</font> LowLevelMouseProc _
  (ByVal idHook <font color="#0000A0">As</font> Long, <font color="#0000A0">ByVal</font> wParam <font color="#0000A0">As</font> Long, lParam <font color="#0000A0">As</font> Long) <font color="#0000A0">As</font> <font color="#0000A0">Long</font>

       <font color="#0000A0">If</font> wParam = WM_LBUTTONDOWN <font color="#0000A0">Then</font>
          <font color="#008000"> 'determine if we are over a range that drags are allowed to initiate from</font>
           <font color="#0000A0">If</font> pDragDropperCBRef.ValidDragSource <font color="#0000A0">Then</font>
               UnhookWindowsHookEx hHook
           <font color="#0000A0">End</font> <font color="#0000A0">If</font>
       <font color="#0000A0">Else</font>
           LowLevelMouseProc = CallNextHookEx(hHook, idHook, wParam, <font color="#0000A0">ByVal</font> lParam)
       <font color="#0000A0">End</font> <font color="#0000A0">If</font>

  <font color="#0000A0">End</font> <font color="#0000A0">Function</font>
</FONT></td></tr></table><button onclick='document.all("1018200784144516").value=document.all("1018200784144516").value.replace(/<br \/>\s\s/g,"");document.all("1018200784144516").value=document.all("1018200784144516").value.replace(/<br \/>/g,"");window.clipboardData.setData("Text",document.all("1018200784144516").value);'>Copy to Clipboard</BUTTON><textarea style="position:absolute;visibility:hidden" name="1018200784144516" wrap="virtual">
Option Explicit

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 UnhookWindowsHookEx Lib "user32" (ByVal hHook 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 Const WH_MOUSE_LL As Long = 14
Private Const WM_LBUTTONDOWN As Long = &H201

Private hHook As Long
Private pDragDropperCBRef As DragDropper

Sub DragDropperMouseHookUtility(DragDropperCBRef As DragDropper)
Set pDragDropperCBRef = DragDropperCBRef
hHook = SetWindowsHookEx(WH_MOUSE_LL, AddressOf LowLevelMouseProc, Application.Hinstance, 0)
End Sub

Sub StopHooking()
Set pDragDropperCBRef = Nothing
UnhookWindowsHookEx hHook
End Sub


Public Function LowLevelMouseProc _
(ByVal idHook As Long, ByVal wParam As Long, lParam As Long) As Long

If wParam = WM_LBUTTONDOWN Then
'determine if we are over a range that drags are allowed to initiate from
If pDragDropperCBRef.ValidDragSource Then
UnhookWindowsHookEx hHook
End If
Else
LowLevelMouseProc = CallNextHookEx(hHook, idHook, wParam, ByVal lParam)
End If

End Function</textarea>

 

[erik.van.geit]

Jaafar,

Using Excel 2000 (exceptionally online from workplace where they do not have more recent versions) I get an error 438 "property or method not supported by this object.
on this line
hhkLowLevelMouse = SetWindowsHookEx ....

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

If you want I'll test again from home with XP.

best regards,
Erik

 

[Legacy 98055]

Eric. I'm pretty sure that the Application.Hinstance property was not available until Excel 2002 - XP.

 

[Legacy 98055]

This version seems stable so far. The DragDropper's class terminate event was not firing and I was unable to figure out why. There is a reference to the DragDropper object in the standard module but that would have been set to nothing in the terminate event. Anyway, I added a Kill method to the class and it seems to be running ok.

The next thing I am trying to do is clean up the drag effect graphical residue. I invalidate the entire window for repainting at the conclusion of the drop but I cannot invalidate the entire client rectangle repeatedly, during the drag, as this causes the screen to flicker. I am wondering, Jaafar, if you know of a way for me to track the path of the dragged image control so I can invalidate only the region that needs to be repainted during the drag?

Thanks again....

DragDrop5.zip

 

[erik.van.geit]

strange ...
Tried Jaraafs workbook: nothing happened, only the mouse icon changed to an arrow. No custom drag.
Toms project (dragdrop5): no custom drag for me neighther.
Windows 98SE, Excel XP

Did I miss something?

It's of course only me on my machine Just to let you know that I tried it: and hoping others will follow my example.

kind regards,
Erik

 

[Jaafar Tribak]

Erik, Thanks for testing the code. As Tom mentioned, the Hinstance prop was introduced in XL2002. You also tested it in Windows 98SE, Excel XP and really don't know why it didn't work.

Tom, I am not getting the desired results with the InValidateRect function either. I am still experimenting in order to see if i can eliminate the graphical residues left when dragging the image control. I am also trying to improve the mouse control.

If i come up with something worthwhile, i'll post it .

Regards.

 

[Jaafar Tribak]

Hi Tom,

Here i have an improved version of the previous code which i have tested and seems to achieve all of the following:

- Mouse down, mouse move, mouse up (as requested)
- Cleaner dragging -No graphical residue
- No need for the tacky toggling of the Sheet protection as in the previous code
- No erratic mouse pointer

Only little drawback (hardly noticeable) is that when dragging the mouse very fast, the custom dragging may sometimes not happen .

I have tried but couldn't incorporate the code below to your DragDropper Class so i am still using the same Non-Class approach as before.

Here is a Workbook Demo : http://www.savefile.com/files/1137584


Here is the code that goes in a Standard Module:

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()

    Call Hook_Mouse

End Sub

Sub DisableDrag_Drop()

    '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
    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, 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(1).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(1).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(1).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(1).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(1).Image1
                        .Left = (.Left) - (dOldPosX - dPosX)
                        .Top = (.Top) - (dOldPosY - dPosY)
                    End With
                    Set TopLeftCell = Sheets(1).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

The next thing I am trying to do is clean up the drag effect graphical residue

Tom, i noticed that the graphical residue of the dragging happens upon mouse down only and NOT during the actual dragging. i have used this to my advantage so i didn't need to repeat the cleaning code inside the WM_MOUSEMOVE loop and didn't need any of the graphical functions such as InvalidateRect.

Hope this time round the code is up to the challenge

Regards.

 

[erik.van.geit]

Hi, Jafaar,

actions
1. click button "enable custom drag & drop"
2. click in any cell column A
3. hold mouse down and drag to column B
nothing happened.

Then I've put a breakpoint at each Sub. When clicking the button "custom drag & drop", the appropriate Subs were called. No other Subs were called doing any other selecting or dragging.

Might not work with Windows 98SE (+ Office XP). So it seems like I cannot help you further with testing: sorry.

At least this time my PC didn't crash trying out your code

kind regards,
Erik

 

[Legacy 98055]

Hi, Jafaar. Thanks for all of your help. You have solved the two major problems that I have come up against so far.

- Cleaner dragging -No graphical residue

Indeed! And better than I had hoped for. I tried to locate the differences in our code and reconcile them to duplicate the very clean dragging you have produced but could not. I very much wish to keep the class interface with the three events if at all possible. The main differences I noted in our approaches were that you were using a picture created on the hard-drive as opposed to one created in memory and using the mousemove messages within the callback as opposed to the mousemove event of the image. I tried both and still could not produce the same good results in my own file. How did you come up with the clean dragging? There must be some difference that I am not seeing...

Only little drawback (hardly noticeable) is that when dragging the mouse very fast, the custom dragging may sometimes not happen .

I tried to lose the drag and it never happened. It worked flawlessly every time.

I have tried but couldn't incorporate the code below to your DragDropper Class so i am still using the same Non-Class approach as before.

I don't see any problem in using your code in a class. Give me a couple of days or so and I'll post back with the results.

Thanks again...

 

[Jaafar Tribak]

Tom- Glad to help.

How did you come up with the clean dragging? There must be some difference that I am not seeing...

As i mentioned in my previous post, i noticed that for some reason which i can't understand myself, the graphical residue happens only upon mouse down and NOT during the actual dragging. so i thought maybe if i set the visible property to False in the WM_LBUTTONDOWN procedure and setting it to True in the WM_MOUSEMOVE maybe this could solve the problem. Indeed, I tried it and it worked beautifuly. I hope this or something similar can be implemented in your DragDroper Class.


Erik,

At least this time my PC didn't crash trying out your code

Glad it didn't I recall you had a couple of nasty XL crashes before while attempting to use some code i posted involving similar hook technics. I still have no clue why it works in some machines and not in others specially when no error is generated by the code as in this case !

Again, thanks for taking an interest in this Erik.

Regards.