Jaafar Tribak
Well-known Member
- Joined
- Dec 5, 2002
- Messages
- 9,621
- Office Version
- 2016
- Platform
- Windows
Hi all,
Inspired by this question asked here :http://www.mrexcel.com/board2/viewtopic.php?t=214429&highlight=
I managed to put together a Class that can make UserForm Controls Drag & Drop at run time posible. ( not the exact real thing but a close imitation)
Here is a WorkBook Demo to download : http://www.savefile.com/files/5994236
Note : If the above Download workbook doesn't work ( I have noticed it can freeze when clicking on a control) try saving the file first and giving it a different name.:
How it works :
To set a control to Drag&Drop mode, just right click it and a PopUp Menu will appear. Click the PopUp Menu button and you are done.
To exit the Drag&Drop mode for the Control, jus right click it again and untick the PopUp Menu Button.
See the Test Macro below to see how you can use this Class in code.
For the record here is the whole Project code:
1- In a Class Module named (ControlDragAndDropClassMain)
2- In another Class Module named (ControlDragAndDropClass)
3- In a Standard Module
This is a Test routine that uses the Class to allow all the Controls in UserForm1 to be repositioned at run time :
Enhancing this Class to also allow Resizing Controls would be nice.I'll have a go if I find the time.
Any feedback is much appreciated.
Regards.
Inspired by this question asked here :http://www.mrexcel.com/board2/viewtopic.php?t=214429&highlight=
I managed to put together a Class that can make UserForm Controls Drag & Drop at run time posible. ( not the exact real thing but a close imitation)
Here is a WorkBook Demo to download : http://www.savefile.com/files/5994236
Note : If the above Download workbook doesn't work ( I have noticed it can freeze when clicking on a control) try saving the file first and giving it a different name.:
How it works :
To set a control to Drag&Drop mode, just right click it and a PopUp Menu will appear. Click the PopUp Menu button and you are done.
To exit the Drag&Drop mode for the Control, jus right click it again and untick the PopUp Menu Button.
See the Test Macro below to see how you can use this Class in code.
For the record here is the whole Project code:
1- In a Class Module named (ControlDragAndDropClassMain)
Code:
Option Explicit
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Type POINTAPI
X As Long
Y As Long
End Type
Private Type tRect
tLeft As Long
tTop As Long
tRight As Long
tBottom As Long
End Type
Private tPointNewPos As POINTAPI
Private tPointOldPos As POINTAPI
Private objCmb As CommandBar
Private WithEvents AnchorTxtCtrl As MSForms.TextBox
Private WithEvents AnchorLblCtrl As MSForms.Label
Private WithEvents AnchorChkCtrl As MSForms.CheckBox
Private WithEvents AnchorCmbCtrl As MSForms.ComboBox
Private WithEvents AnchorLstCtrl As MSForms.ListBox
Private WithEvents AnchorCmdCtrl As MSForms.CommandButton
Private WithEvents AnchorImgCtrl As MSForms.Image
Private WithEvents AnchorOptCtrl As MSForms.OptionButton
Private WithEvents AnchorTglCtrl As MSForms.ToggleButton
Private Sub AnchorImgCtrl_MouseDown _
(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Call Generic_MouseDownEvent(AnchorImgCtrl, Button)
End Sub
Private Sub AnchorImgCtrl_MouseMove _
(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Call Generic_MouseMoveEvent(AnchorImgCtrl, Button, X, Y)
End Sub
Private Sub AnchorImgCtrl_MouseUp _
(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Call Generic_MouseUpEvent(AnchorImgCtrl)
End Sub
Private Sub AnchorLblCtrl_MouseDown _
(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Call Generic_MouseDownEvent(AnchorLblCtrl, Button)
End Sub
Private Sub AnchorLblCtrl_MouseMove _
(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Call Generic_MouseMoveEvent(AnchorLblCtrl, Button, X, Y)
End Sub
Private Sub AnchorLblCtrl_MouseUp _
(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Call Generic_MouseUpEvent(AnchorLblCtrl)
End Sub
Private Sub AnchorLstCtrl_MouseDown _
(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Call Generic_MouseDownEvent(AnchorLstCtrl, Button)
End Sub
Private Sub AnchorLstCtrl_MouseMove _
(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Call Generic_MouseMoveEvent(AnchorLstCtrl, Button, X, Y)
End Sub
Private Sub AnchorLstCtrl_MouseUp _
(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Call Generic_MouseUpEvent(AnchorLstCtrl)
End Sub
Private Sub AnchorOptCtrl_MouseDown _
(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Call Generic_MouseDownEvent(AnchorOptCtrl, Button)
End Sub
Private Sub AnchorOptCtrl_MouseMove _
(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Call Generic_MouseMoveEvent(AnchorOptCtrl, Button, X, Y)
End Sub
Private Sub AnchorOptCtrl_MouseUp _
(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Call Generic_MouseUpEvent(AnchorOptCtrl)
End Sub
Private Sub AnchorTglCtrl_MouseDown _
(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Call Generic_MouseDownEvent(AnchorTglCtrl, Button)
End Sub
Private Sub AnchorTglCtrl_MouseMove _
(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Call Generic_MouseMoveEvent(AnchorTglCtrl, Button, X, Y)
End Sub
Private Sub AnchorTglCtrl_MouseUp _
(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Call Generic_MouseUpEvent(AnchorTglCtrl)
End Sub
Private Sub AnchorTxtCtrl_MouseDown _
(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Call Generic_MouseDownEvent(AnchorTxtCtrl, Button)
End Sub
Private Sub AnchorTxtCtrl_MouseMove _
(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Call Generic_MouseMoveEvent(AnchorTxtCtrl, Button, X, Y)
End Sub
Private Sub AnchorTxtCtrl_MouseUp _
(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Call Generic_MouseUpEvent(AnchorTxtCtrl)
End Sub
Private Sub AnchorChkCtrl_MouseDown _
(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Call Generic_MouseDownEvent(AnchorChkCtrl, Button)
End Sub
Private Sub AnchorChkCtrl_MouseMove _
(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Call Generic_MouseMoveEvent(AnchorChkCtrl, Button, X, Y)
End Sub
Private Sub AnchorChkCtrl_MouseUp _
(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Call Generic_MouseUpEvent(AnchorChkCtrl)
End Sub
Private Sub AnchorCmbCtrl_MouseDown _
(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Call Generic_MouseDownEvent(AnchorCmbCtrl, Button)
End Sub
Private Sub AnchorCmbCtrl_MouseMove _
(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Call Generic_MouseMoveEvent(AnchorCmbCtrl, Button, X, Y)
End Sub
Private Sub AnchorCmbCtrl_MouseUp _
(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Call Generic_MouseUpEvent(AnchorCmbCtrl)
End Sub
Private Sub AnchorCmdCtrl_MouseDown _
(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Call Generic_MouseDownEvent(AnchorCmdCtrl, Button)
End Sub
Private Sub AnchorCmdCtrl_MouseMove _
(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Call Generic_MouseMoveEvent(AnchorCmdCtrl, Button, X, Y)
End Sub
Private Sub AnchorCmdCtrl_MouseUp _
(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Call Generic_MouseUpEvent(AnchorCmdCtrl)
End Sub
Public Sub AllowDragAndDrop(Ctrl As MSForms.Control)
Select Case TypeName(Ctrl)
Case Is = "TextBox"
Set AnchorTxtCtrl = Ctrl
Case Is = "Label"
Set AnchorLblCtrl = Ctrl
Case Is = "CheckBox"
Set AnchorChkCtrl = Ctrl
Case Is = "ComboBox"
Set AnchorCmbCtrl = Ctrl
Case Is = "ListBox"
Set AnchorLstCtrl = Ctrl
Case Is = "CommandButton"
Set AnchorCmdCtrl = Ctrl
Case Is = "Image"
Set AnchorImgCtrl = Ctrl
Case Is = "OptionButton"
Set AnchorOptCtrl = Ctrl
Case Is = "ToggleButton"
Set AnchorTglCtrl = Ctrl
End Select
'\ create a rightClick popup commandbar for each ctrl
'\ will be used to set the Drag&Drop mode for the ctrl
Set objCmb = Application.CommandBars.Add(Position:=msoBarPopup)
With objCmb
With .Controls.Add(msoControlButton)
.Caption = "Move Control"
.State = msoButtonUp
.OnAction = "MakeMovable"
.Tag = Ctrl.Name
End With
End With
End Sub
Private Sub Class_Terminate()
'\ ensure all created popups are deleted
On Error Resume Next
objCmb.Delete
End Sub
Public Sub ApplyTo(frm As MSForms.UserForm)
'\ store the form in a global variable
Set objForm = frm
Call CreateShadowLabels(frm)
End Sub
Private Sub Generic_MouseDownEvent _
(Ctrl As MSForms.Control, ByVal Button As Integer)
'\ is mouse is left clicked ?
If Button = 2 Then
'\ if so, is mouse over a different control not
'\ on Drag&Drop mode ?
If Not Ctrl Is g_ObjLastMovableControl Then
'\ if so,ensure right click commandbar button
'\ state is up
objCmb.Controls(1).State = msoButtonUp
End If
'\ assign control to a global variable..
'\ ..will be needed in the OnAction procedure of the
'\ popup commandbar button
Set g_ObjLastMovableControlTemp = Ctrl
'\ show the right click popup button
objCmb.ShowPopup
'\ has the user set the Drag&Drop mode by
'\ ticking the commandbar button ?
If objCmb.Controls(1).State = msoButtonDown Then
'\ if so, set the mouse pointer and turn the control
'\ backcolor into white to indicate that the
'\ control is on Drag&Drop mode.
Ctrl.MousePointer = fmMousePointerSizeAll
objForm.Controls(objCmb.Controls(1).Tag).BackColor = vbWhite
End If
End If
End Sub
Private Sub Generic_MouseMoveEvent _
(Ctrl As MSForms.Control, ByVal Button As Integer, ByVal X As Single, ByVal Y As Single)
Const PointsPerPixel As Double = 0.75
'\ first let's set the mouse pointer dinamically:
'\ is mouse pointer over a control on Drag&Drop mode ?
If (g_ObjLastMovableControl Is Ctrl) Then
'\ if so, ensure mouse pointer is set to "SizeAll" if over
If Ctrl.MousePointer <> fmMousePointerSizeAll Then
Ctrl.MousePointer = fmMousePointerSizeAll
End If
'\ otherwise set pointer back to default
Else
Ctrl.MousePointer = fmMousePointerDefault
End If
'\ get the x & y screen postion of the mouse pointer
'\ dynamically as the mouse moves over the control
GetCursorPos tPointNewPos
'\ let's simulate here a Drag&Drop operation:
'\ see if the mouse is moving over a control that is on Drag&Drop
'\ mode while the left mouse button is held down .
If Button = 1 And (g_ObjLastMovableControl Is Ctrl) Then
'\ if so, let's dynamically adapt the shadow labels.
'\ the objective of these labels is to create
'\ a square of dots that appears while moving a control
'\ in order to simulate a real Drag&Drop operation
'\ first define the initial dimensions\positions of the shadow
'\ labels based on the size of the underlying control to be dragged.
'\ if tPointOldPos.X = 0 it means we are just before the drag operation.
If tPointOldPos.X = 0 Then
With lblTop
.Width = Ctrl.Width
.Top = Ctrl.Top
.Left = Ctrl.Left
.Visible = True
End With
With lblTopEx
.Left = lblTop.Left + lblTop.Width
.Top = Ctrl.Top
.Visible = True
End With
With lblLeft
.Height = Ctrl.Height
.Top = Ctrl.Top
.Left = Ctrl.Left
.Visible = True
End With
With lblBottom
.Width = Ctrl.Width
.Top = Ctrl.Top + Ctrl.Height
.Left = Ctrl.Left
.Visible = True
End With
With lblBottomEx
.Left = lblBottom.Left + lblBottom.Width
.Top = lblBottom.Top
.Visible = True
End With
With lblRight
.Height = Ctrl.Height
.Top = Ctrl.Top
.Left = (Ctrl.Left + Ctrl.Width)
.Visible = True
End With
'\ if tPointOldPos.X <> 0 it means the dragging operation
'\ is already underway.
Else
'\ ensure the mouse pointer is set to MousePointerSizeAll
If Ctrl.MousePointer = fmMousePointerSizeAll Then
'\ increment the Top & Left properties of the shadow labels
'\ by the mouse move increment .
lblTop.Left = lblTop.Left + ((tPointNewPos.X - tPointOldPos.X) _
* PointsPerPixel)
lblTop.Top = lblTop.Top + ((tPointNewPos.Y - tPointOldPos.Y) _
* PointsPerPixel)
lblTopEx.Left = lblTopEx.Left + ((tPointNewPos.X - tPointOldPos.X) _
* PointsPerPixel)
lblTopEx.Top = lblTopEx.Top + ((tPointNewPos.Y - tPointOldPos.Y) _
* PointsPerPixel)
lblLeft.Left = lblLeft.Left + ((tPointNewPos.X - tPointOldPos.X) _
* PointsPerPixel)
lblLeft.Top = lblLeft.Top + ((tPointNewPos.Y - tPointOldPos.Y) _
* PointsPerPixel)
lblBottom.Left = lblBottom.Left + ((tPointNewPos.X - tPointOldPos.X) _
* PointsPerPixel)
lblBottom.Top = lblBottom.Top + ((tPointNewPos.Y - tPointOldPos.Y) _
* PointsPerPixel)
lblBottomEx.Left = lblBottomEx.Left + ((tPointNewPos.X - tPointOldPos.X) _
* PointsPerPixel)
lblBottomEx.Top = lblBottomEx.Top + ((tPointNewPos.Y - tPointOldPos.Y) _
* PointsPerPixel)
lblRight.Left = lblRight.Left + ((tPointNewPos.X - tPointOldPos.X) _
* PointsPerPixel)
lblRight.Top = lblRight.Top + ((tPointNewPos.Y - tPointOldPos.Y) _
* PointsPerPixel)
End If
End If
'\ store the previous mouse pointer coordomates
'\ to be compared to the current coordonates next time round
tPointOldPos.X = tPointNewPos.X
tPointOldPos.Y = tPointNewPos.Y
End If
'\ reset tPointOldPos public var when the control
'\ is dropped in a new location...ready for next drag operation
If Button <> 1 Then tPointOldPos.X = 0: tPointOldPos.Y = 0
End Sub
Private Sub Generic_MouseUpEvent(Ctrl As MSForms.Control)
'\ mouse button up means the drag operation is over
'\ so let's hide all the shadow labels.
lblTop.Visible = False
lblLeft.Visible = False
lblBottom.Visible = False
lblRight.Visible = False
lblTopEx.Visible = False
lblBottomEx.Visible = False
'\ drag operation over so let's drop the
'\ control in the new location.
If Ctrl.MousePointer = fmMousePointerSizeAll _
And tPointOldPos.X <> 0 Then
Ctrl.Left = lblTop.Left
Ctrl.Top = lblTop.Top
End If
End Sub
Private Sub CreateShadowLabels(frm As MSForms.UserForm)
Dim Strg As String
Dim i As Byte
Dim lblTemp As MSForms.Label
'\ create a string of "+" characters
'\ will be needed for he shadow labels
For i = 1 To 150
Strg = Strg & Chr(43) & " "
Next
'\ now create the shadow labels
For i = 1 To 6
Set lblTemp = frm.Controls.Add("Forms.Label.1")
With lblTemp
If i Mod 2 = 1 Then
.Height = 10
Else
.Width = 10
End If
If i > 4 Then
.AutoSize = True
.Caption = Chr(43)
Else
.Caption = Strg
End If
.ForeColor = vbBlack
.BackStyle = fmBackStyleTransparent
.Visible = False
End With
Select Case i
Case Is = 1
Set lblTop = lblTemp
Case Is = 3
Set lblBottom = lblTemp
Case Is = 2
Set lblLeft = lblTemp
Case Is = 4
Set lblRight = lblTemp
Case Is = 5
Set lblTopEx = lblTemp
Case Is = 6
Set lblBottomEx = lblTemp
End Select
Next
Set lblTemp = Nothing
End Sub2- In another Class Module named (ControlDragAndDropClass)
Code:
Option Explicit
Dim objDragAndDrop As ControlDragAndDropClassMain
Private Sub Class_Initialize()
Set cCollection = New Collection
End Sub
Public Sub AllowDragAndDrop(Ctrl As MSForms.Control)
Set objDragAndDrop = New ControlDragAndDropClassMain
objDragAndDrop.AllowDragAndDrop Ctrl
'\ add all newly created ControlDragAndDropClassMain objects to
'\ a global variable so they don't go out of scope
cCollection.Add objDragAndDrop
End Sub
Public Sub ApplyTo(frm As MSForms.UserForm)
Set objDragAndDrop = New ControlDragAndDropClassMain
objDragAndDrop.ApplyTo frm
End Sub
Private Sub Class_Terminate()
'\ cleanup - important !!- needed to delete all popup cmndbars
Set cCollection = Nothing
End Sub3- In a Standard Module
Code:
Option Explicit
Public lblTop As MSForms.Label
Public lblLeft As MSForms.Label
Public lblBottom As MSForms.Label
Public lblRight As MSForms.Label
Public lblTopEx As MSForms.Label
Public lblBottomEx As MSForms.Label
Public g_ObjLastMovableControlTemp As MSForms.Control
Public g_ObjLastMovableControl As MSForms.Control
Public objForm As MSForms.UserForm
Public cCollection As Collection
Public objLastComnbarCtrl As CommandBarControl
Public lngLastControlcolor As Double
Public Sub MakeMovable()
'\ avoid err if objLastComnbarCtrl is not initialised
On Error Resume Next
objForm.Controls(objLastComnbarCtrl.Tag).BackColor = lngLastControlcolor
On Error GoTo 0
If CommandBars.ActionControl.State = msoButtonUp Then
CommandBars.ActionControl.State = msoButtonDown
Set g_ObjLastMovableControl = g_ObjLastMovableControlTemp
Else
CommandBars.ActionControl.State = msoButtonUp
Set g_ObjLastMovableControl = Nothing
End If
Set objLastComnbarCtrl = CommandBars.ActionControl
lngLastControlcolor = objForm.Controls(objLastComnbarCtrl.Tag).BackColor
End SubThis is a Test routine that uses the Class to allow all the Controls in UserForm1 to be repositioned at run time :
Code:
Option Explicit
Sub Test()
Dim objForm As UserForm1
Dim objControl As MSForms.Control
Dim objDragAndDropClass As ControlDragAndDropClass
Set objForm = New UserForm1
Set objDragAndDropClass = New ControlDragAndDropClass
objDragAndDropClass.ApplyTo objForm
For Each objControl In objForm.Controls
With objDragAndDropClass
.AllowDragAndDrop objControl
End With
Next
objForm.Show
Set objDragAndDropClass = Nothing
Set objForm = Nothing
Set objControl = Nothing
End SubEnhancing this Class to also allow Resizing Controls would be nice.I'll have a go if I find the time.
Any feedback is much appreciated.
Regards.
