[AccessD] Generic Procedure on form controls for Drag and Drop

John Bodin jbodin at sbor.com
Sat Feb 9 09:34:53 CST 2013


Hi John,

The code I was looking at was from Smart Access January 2004 that references
some old versions of Access, but the process seems to work.  Dan Steele and
others.  Link to post with Zip file is here:
http://www.access-programmers.co.uk/forums/showthread.php?t=221317

You can put a couple of Textboxes onto a form and then the sample code was
assigned to the On Mouse Down/Up/Move.  Code for those are below and below
that are the two modules that do the work.

Thanks for help!

John
-----------------

' Event Procedures for TextBoxes
'####################
Private Sub txtTextBox1_MouseDown(Button As Integer, Shift As Integer, X As
Single, Y As Single)
On Error GoTo Err_txtTextBox1_MouseDown

    StartDrag Me

End_txtTextBox1_MouseDown:
    Exit Sub

Err_txtTextBox1_MouseDown:
    MsgBox Err.Description & " (" & Err.Number & ") in " & _
        Me.Name & ".txtTextBox1MouseDown", _
        vbOKOnly + vbCritical, "Smart Access Answer Column"
    Resume End_txtTextBox1_MouseDown

End Sub

Private Sub txtTextBox1_MouseMove(Button As Integer, Shift As Integer, X As
Single, Y As Single)
On Error GoTo Err_txtTextBox1_MouseMove

    DetectDrop Me, Me!txtTextBox1, Button, Shift, X, Y

End_txtTextBox1_MouseMove:
    Exit Sub

Err_txtTextBox1_MouseMove:
    MsgBox Err.Description & " (" & Err.Number & ") in " & _
        Me.Name & ".txtTextBox1_MouseMove", _
        vbOKOnly & vbCritical, "Smart Access Answer Column"
    Resume End_txtTextBox1_MouseMove

End Sub

Private Sub txtTextBox1_MouseUp(Button As Integer, Shift As Integer, X As
Single, Y As Single)
On Error GoTo Err_txtTextBox1_MouseUp

    StopDrag

End_txtTextBox1_MouseUp:
    Exit Sub

Err_txtTextBox1_MouseUp:
    MsgBox Err.Description & " (" & Err.Number & ") in " & _
        Me.Name & ".txtTextBox1MouseUp", _
        vbOKOnly & vbCritical, "Smart Access Answer Column"
    Resume End_txtTextBox1_MouseUp

End Sub
'#########################


'mdlDragDrop
'#########################
Option Compare Database
Option Explicit

' Based on code in Microsoft Knowledge Base Article 137650
' ACC: How to Simulate Drag-And-Drop Capabilities
' http://support.microsoft.com/?id=137650

' Declare module-specific variables.
' mfrmDragForm      the form from which we're dragging the value
' mctlDragCtrl     the control (on mfrmDragForm) from which we're dragging
the value
' msngDropTime     the timer information about when we dropped the value
' mbytCurrentMode  what we're currently doing (Dropping or Dragging)
'                  This field should only have values NO_MODE, DROP_MODE or
DRAG_MODE
' mbytDragQuantity whether we're dragging a single value, or multiple values
'                  This field should only have values NO_MODE, SINGLE_VALUE
or MULTI_VALUE
'
' NOTE: Since this is being developed in Access 97, which does not support
Enums, I've defined
' mbytCurrentMode and mintDragQuanity as bytes. If using a higher version
that supports Enums,
' it might be more appropriate to change the domain of these two variables.

Private mfrmDragForm As Form
Private mctlDragCtrl As Control
Private msngDropTime As Single
Private mbytCurrentMode As Byte
Private mbytDragQuantity As Byte

Private Const MAX_DROP_TIME = 0.1
Private Const NO_MODE = 0
Private Const DROP_MODE = 1
Private Const DRAG_MODE = 2
Private Const SINGLE_VALUE = 1
Private Const MULTI_VALUE = 2

Sub StartDrag(SourceForm As Form)
On Error GoTo Err_StartDrag

' This code was originally written by
' Doug Steele, MVP  AccessHelp at rogers.com
' http://I.Am/DougSteele
' You are free to use it in any application
' provided the copyright notice is left unchanged.
'
' Description: This routine should be called from the MouseDown event of any
'              control you want to have capable of being dragged. It sets
'              some module-level variables to indicate that a Drop event
'              has occurred. Note that, of the standard Access controls,
only
'              list boxes have a multi-select capability. If you're using
other
'              controls that support multi-select, change the code below
accordingly.
'
' Inputs:      SourceForm: The form containing the control being dragged.
'
' Returns:     Nothing

' NOTE: You should not use Screen.ActiveForm in place of
' SourceForm because you may be dragging from a subform.
    Set mfrmDragForm = SourceForm
    Set mctlDragCtrl = Screen.ActiveControl
    mbytCurrentMode = DRAG_MODE
    If TypeOf mctlDragCtrl Is ListBox Then
        If mctlDragCtrl.ItemsSelected.Count > 1 Then
            mbytDragQuantity = MULTI_VALUE
        Else
            mbytDragQuantity = SINGLE_VALUE
        End If
    Else
        mbytDragQuantity = SINGLE_VALUE
    End If
    mfrmDragForm.SetFocus
    SetDragCursor

End_StartDrag:
    Exit Sub

Err_StartDrag:
    Err.Raise Err.Number, "StartDrag(" & SourceForm.Name & ")",
Err.Description
    Resume End_StartDrag

End Sub

Sub StopDrag()
On Error GoTo Err_StopDrag

' This code was originally written by
' Doug Steele, MVP  AccessHelp at rogers.com
' http://I.Am/DougSteele
' You are free to use it in any application
' provided the copyright notice is left unchanged.
'
' Description: This routine should be called from the MouseUp event of any
'              control you want to have capable of being dragged. It sets
'              some module-level variables to indicate that a Drop event
'              has occurred.
'
' Inputs:      None
'
' Returns:     Nothing

    mbytCurrentMode = DROP_MODE
    mbytDragQuantity = NO_MODE
    msngDropTime = Timer()
    SetDragCursor

End_StopDrag:
    Exit Sub

Err_StopDrag:
    Err.Raise Err.Number, "StopDrag", Err.Description
    Resume End_StopDrag

End Sub

Sub DetectDrop(DropForm As Form, _
                DropCtrl As Control, _
                Button As Integer, _
                Shift As Integer, _
                X As Single, _
                Y As Single)

On Error GoTo Err_DetectDrop

' This code was originally written by
' Doug Steele, MVP  AccessHelp at rogers.com
' http://I.Am/DougSteele
' You are free to use it in any application
' provided the copyright notice is left unchanged.
'
' Description: This routine should be called from the MouseMove event of any
'              control you want to be capable of being a target of a dragged
'              control.
'
' Inputs:      DropForm              The form containing the control being
dropped on
'              DropCtrl             The control (on form DropForm) being
dropped on
'              Button, Shift, X, Y  The parameters associated with the
MouseMove event
'
' Returns:     Nothing

' If a drop hasn't happened, then exit.
    
    If mbytCurrentMode <> DROP_MODE Then
        SetDragCursor
        Exit Sub
    Else

' If you have a form with a control that set up for both Drag and Drop,
' it's possible to have a problem when you first open that form.
' Specifically, if the form opens with the cursor in that control, you
' can have a spurious MouseUp event that will have invoked StopDrag.
' In that case, though, there will not have been a MouseDown event that
' invoked StartDrag, so neither mfrmDragForm nor mctlDragCtrl will have
' been set. Check for that situation, just to avoid errors.

        If mfrmDragForm Is Nothing Then
            Exit Sub
        End If
        
        mbytCurrentMode = NO_MODE

' The timer interval lets us check how long it's been between the
' MouseUp event and the MouseMove event. This ensures that the
' MouseMove event does not invoke the Drop procedure unless it is
' the MouseMove event that Microsoft Access automatically fires for
' the Drop control following the MouseUp event of a drag control.
' Subsequent MouseMove events will fail the timer test and be ignored.

        If Timer - msngDropTime > MAX_DROP_TIME Then
            Exit Sub
        Else
' Did we drag/drop onto ourselves?
            If (mctlDragCtrl.Name <> DropCtrl.Name) Or _
                (mfrmDragForm.hwnd <> DropForm.hwnd) Then
' If not, then a successful drag/drop occurred.
                ProcessDrop mfrmDragForm, mctlDragCtrl, DropForm, DropCtrl,
Button, Shift, X, Y
            End If
        End If
    End If

End_DetectDrop:
    Exit Sub

Err_DetectDrop:
    Err.Raise Err.Number, "DetectDrop", Err.Description
    Resume End_DetectDrop

End Sub

Sub ProcessDrop(DragForm As Form, _
                DragCtrl As Control, _
                DropForm As Form, _
                DropCtrl As Control, _
                Button As Integer, _
                Shift As Integer, _
                X As Single, _
                Y As Single)

On Error GoTo Err_ProcessDrop

' This code was originally written by
' Doug Steele, MVP  AccessHelp at rogers.com
' http://I.Am/DougSteele
' You are free to use it in any application
' provided the copyright notice is left unchanged.
'
' Description: This routine should be called from the DetectDrop event of
any
'              control you want to be capable of being a target of a dragged
'              control. This is where everything happens!
'
' Inputs:      DragForm              The form containing the control being
dragged
'              DragCtrl             The control (on form DragForm) being
dragged
'              DropForm              The form containing the control being
dropped on
'              DropCtrl             The control (on form DropForm) being
dropped on
'              Button, Shift, X, Y  The parameters associated with the
MouseMove event
'
' Returns:     Nothing

Dim ctlCurr As Control
Dim strSelectedItems As String
Dim varCurrItem As Variant
    
    If TypeOf DragCtrl Is ListBox Then
' To handle the processing for the listboxes on frmListBoxExample, we
' call another routine, rather than try to embed too much in this routine
        If DragForm.Name = "frmListBoxExample" Then
            ListBoxExample DragForm, DragCtrl, DropForm, DropCtrl, Button,
Shift, X, Y
        Else
            If DragCtrl.ItemsSelected.Count > 0 Then
                For Each varCurrItem In DragCtrl.ItemsSelected
                    strSelectedItems = strSelectedItems &
DragCtrl.ItemData(varCurrItem) & ", "
                Next varCurrItem
                If Len(strSelectedItems) > 2 Then
                    strSelectedItems = Left$(strSelectedItems,
Len(strSelectedItems) - 2)
                End If
                DropCtrl = strSelectedItems
            Else
                DropCtrl = DragCtrl
            End If
        End If
    ElseIf TypeOf DragCtrl Is CheckBox Then
' Assume we only allow dropping check boxes onto text boxes or check boxes
        If TypeOf DropCtrl Is TextBox Then
            DropCtrl = IIf(DragCtrl, "True", "False")
        ElseIf TypeOf DropCtrl Is CheckBox Then
            DropCtrl = DragCtrl
        Else
        End If
    ElseIf TypeOf DragCtrl Is OptionGroup Then
' Assume we only allow dropping option groups onto text boxes
        If TypeOf DropCtrl Is TextBox Then
            Select Case DropCtrl.Name
                Case "txtTextBox1"
                    DropCtrl = DragCtrl
                Case "txtTextBox2"
                    DropCtrl = DragCtrl & ": " &
ReturnSelectedOption(DragCtrl)
                Case Else
            End Select
        Else
        End If
    Else
        DropCtrl = DragCtrl
    End If
    
End_ProcessDrop:
    Exit Sub

Err_ProcessDrop:
    Err.Raise Err.Number, "ProcessDrop", Err.Description
    Resume End_ProcessDrop
    
End Sub

Sub SetDragCursor()
On Error GoTo Err_SetDragCursor

' This code was originally written by
' Doug Steele, MVP  AccessHelp at rogers.com
' http://I.Am/DougSteele
' You are free to use it in any application
' provided the copyright notice is left unchanged.
'
' Description: This routine sets the Mouse Cursor. The image set depends
'              on the value of mbytDragQuantity (and whether or not the
'              "special" icons are present on the workstation)
'              mbytDragQuantity should have been set to either SINGLE_VALUE
'              or MULTI_VALUE in the StartDrag routine.
'
' Inputs:      None
'
' Returns:     Nothing

Dim strIconPath As String
Dim strFolder As String

' This assumes that mbytDragQuantity having a value SINGLE_VALUE (1) will
result
' in using the cursor DRAG1PG.ICO, while a value of MULTI_VALUE (2) will
result
' in cursor DRAG2PG.ICO. A value of NO_MODE (0) for mbytDragQuantity will
set the
' cursor to the Default cursor type.
' In my case, I've put the cursors in the same folder as the database. If
you want them
' somewhere else, you'll have to change the method of assigning the path.
' If the icon files don't exist where I expect them to be, I'll just use the
built-in
' IDC_CROSS icon.
' Oh, and before I forget, the reason SINGLE_VALUE and MULTI_VALUE aren't
part of an Enum
' is because this was developed in Access 97, which doesn't support Enums.

    strFolder = CurrentDb().Name
    strFolder = Left$(strFolder, Len(strFolder) - Len(Dir(strFolder)))

    Select Case mbytDragQuantity
        Case NO_MODE
            Screen.MousePointer = 0
        Case SINGLE_VALUE
            strIconPath = strFolder & "DRAG1PG.ICO"
            If Len(Dir$(strIconPath)) > 0 Then
                SetMouseCursorFromFile strIconPath
            Else
                SetMouseCursor IDC_CROSS
            End If
        Case MULTI_VALUE
            strIconPath = strFolder & "DRAG2PG.ICO"
            If Len(Dir$(strIconPath)) > 0 Then
                SetMouseCursorFromFile strIconPath
            Else
                SetMouseCursor IDC_CROSS
            End If
        Case Else
            Screen.MousePointer = 0
    End Select

End_SetDragCursor:
    Exit Sub

Err_SetDragCursor:
    Err.Raise Err.Number, "SetDragCursor", Err.Description
    Resume End_SetDragCursor

End Sub

Sub ListBoxExample(DragForm As Form, _
                DragCtrl As Control, _
                DropForm As Form, _
                DropCtrl As Control, _
                Button As Integer, _
                Shift As Integer, _
                X As Single, _
                Y As Single)

On Error GoTo Err_ListBoxExample

' This code was originally written by
' Doug Steele, MVP  AccessHelp at rogers.com
' http://I.Am/DougSteele
' You are free to use it in any application
' provided the copyright notice is left unchanged.
'
' Description: This routine should be called from the ProcessDrop procedure.
'              It's used to handle dragging between the 2 list boxes on that
form.
'
' Inputs:      DragForm              The form containing the control being
dragged
'              DragCtrl             The control (on form DragForm) being
dragged
'              DropForm              The form containing the control being
dropped on
'              DropCtrl             The control (on form DropForm) being
dropped on
'              Button, Shift, X, Y  The parameters associated with the
MouseMove event
'
' Returns:     Nothing
    

Dim dbCurr As DAO.Database
Dim strSQL As String
Dim strMessage As String
Dim strWhere As String
Dim varCurrItem As Variant

    Set dbCurr = CurrentDb()
    
    strSQL = "UPDATE Customers SET Selected=" & _
            IIf(DragCtrl.Name = "lstListBox1", "True", "False")
    
    If (Shift And acShiftMask) = 0 Then
        If DragCtrl.ItemsSelected.Count > 0 Then
            For Each varCurrItem In DragCtrl.ItemsSelected
                strWhere = strWhere & "'" & DragCtrl.ItemData(varCurrItem) &
"', "
            Next varCurrItem
            If Len(strWhere) > 2 Then
                strWhere = " WHERE [CustomerID] IN (" & Left$(strWhere,
Len(strWhere) - 2) & ")"
            End If
        Else
            strWhere = " WHERE [CustomerID] = '" & DragCtrl & "'"
        End If
    End If
    
    If Len(strWhere) > 0 Then
        strSQL = strSQL & strWhere
    End If
    
    dbCurr.Execute strSQL, dbFailOnError

    DragCtrl.Requery
    DropCtrl.Requery

End_ListBoxExample:
    Set dbCurr = Nothing
    Exit Sub

Err_ListBoxExample:
    Err.Raise Err.Number, "ListBoxExample", Err.Description
    Resume End_ListBoxExample
    
End Sub
'#########################

'mdlMousePointer
'#########################
Option Compare Database
Option Explicit

' This mouse cursor code is from http://www.mvps.org/access/api/api0044.htm
' Use SetMouseCursorFromFile along with a path to an .ICO file.
' Use SetMouseCursor along with one of the following constants:

Public Const IDC_APPSTARTING As Long = 32650&
Public Const IDC_HAND As Long = 32649&
Public Const IDC_ARROW As Long = 32512&
Public Const IDC_CROSS As Long = 32515&
Public Const IDC_IBEAM As Long = 32513&
Public Const IDC_ICON As Long = 32641&
Public Const IDC_NO As Long = 32648&
Public Const IDC_SIZE As Long = 32640&
Public Const IDC_SIZEALL As Long = 32646&
Public Const IDC_SIZENESW As Long = 32643&
Public Const IDC_SIZENS As Long = 32645&
Public Const IDC_SIZENWSE As Long = 32642&
Public Const IDC_SIZEWE As Long = 32644&
Public Const IDC_UPARROW As Long = 32516&
Public Const IDC_WAIT As Long = 32514&

Declare Function LoadCursorBynum Lib "user32" _
    Alias "LoadCursorA" ( _
    ByVal hInstance As Long, _
    ByVal lpCursorName As Long _
) As Long

Declare Function LoadCursorFromFile Lib "user32" _
    Alias "LoadCursorFromFileA" ( _
    ByVal lpFileName As String _
) As Long

Declare Function SetCursor Lib "user32" ( _
    ByVal hCursor As Long _
) As Long

Function SetMouseCursor(CursorType As Long)
Dim lngRet As Long

    lngRet = LoadCursorBynum(0&, CursorType)
    lngRet = SetCursor(lngRet)

End Function

Function SetMouseCursorFromFile(strPathToCursor As String)
Dim lngRet As Long

    lngRet = LoadCursorFromFile(strPathToCursor)
    lngRet = SetCursor(lngRet)

End Function
'#######################

-----Original Message-----
From: accessd-bounces at databaseadvisors.com
[mailto:accessd-bounces at databaseadvisors.com] On Behalf Of John W Colby
Sent: Saturday, February 09, 2013 10:07 AM
To: Access Developers discussion and problem solving
Subject: Re: [AccessD] Generic Procedure on form controls for Drag and Drop

John,

Paste the code in this email thread which allows the drag and drop to work.
I will look at moving the code into a class solution and return a demo.

John W. Colby

Reality is what refuses to go away
when you do not believe in it

On 2/6/2013 1:55 PM, John Bodin wrote:
> Hello,
>
>   
>
> New to this list and need some guidance on a form I've developed (I 
> posted this on LinkedIn and got a few links with good information, but 
> still having issues).
>
>   
>
> I have a grid of many text boxes on a form in an Access 2003 app that 
> I fill from a table upon opening the form as well as when the user 
> changes a date box. I add some generic procedure calls on the fly to 
> each text box where I pass the control to the generic function (for 
> instance, I'll add a double-click event to text box "Txt101" as 
> "=TxtBoxDblClick([Txt101])". This will pass the control to my function 
> TxtBoxDblClick so I can react to it.) This all works fine for all text 
> boxes and I reference just one (same) routine for each control.
>
> I'm trying to experiment with Drag and Drop and found some code that I 
> can get to work if at Design time, I add three event procedures to a 
> text box control (Mouse Down/Up/Move). If I do this to two different 
> controls, creating 3 event procedures for each at design time, I can 
> successfully drag and drop between the two controls. So the drag and 
> drop code looks like it works.
>
> My problem is, I want to have 3 generic routines like my 
> TxtBoxDblClick function, that I can add on the fly to the On Mouse 
> Down/Up/Move events and I can't figure out the syntax and/or code to 
> make this happen. I can add the custom Functions no problem, but I 
> know I need to be able to deal with the Button, Shift, X & Y 
> parameters somehow. I can pass the control to the custom function, but 
> am unable to reference the Button, Shift, X & Y parameters. I'm 
> guessing I'll need to create some type of class possibly? If so, can 
> someone provide some sample code on how to do this what the calls 
> would be?  Thanks for any ideas. John
>
>   
>

--
AccessD mailing list
AccessD at databaseadvisors.com
http://databaseadvisors.com/mailman/listinfo/accessd
Website: http://www.databaseadvisors.com




More information about the AccessD mailing list