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