Drag&Drop UserForm Controls at Run Time ! ( Class )

Jaafar Tribak

Well-known Member
Joined
Dec 5, 2002
Messages
9,775
Office Version
  1. 2016
Platform
  1. 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)

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 Sub


2- 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 Sub


3- 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 Sub



This 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 Sub


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.
 

Excel Facts

Ambidextrous Undo
Undo last command with Ctrl+Z or Alt+Backspace. If you use the Undo icon in the QAT, open the drop-down arrow to undo up to 100 steps.
Has anyone tried this ? Did it work ok ?

I have only tetsed this in XL2002 so I would be interested to have some feedback on whether it works in different versions.

Regards.
 
Upvote 0
Jaafar

Just downloaded the file.

2 problems.

1 Runtime error when form opened via button on this line.
Code:
objCmb.Delete

2 No popup menu when right clicking controls when form opened from VBE.

Solved 1 by changing one of my error checking options.

But now when I right click a control and select Move Control I can't move the control.

And the next time I right click and select Move Control I get a 400 error, with no message.

I'm using 2000 if that makes a difference.

I'll try saving the file under another name to see if that makes a difference.

EDIT: After saving under a different name it worked.:)
 
Upvote 0
Jaafar

EDIT: After saving under a different name it worked.:)


Cool .

Yes that 400 Error is what I too got when I first run the download.
Why it only works if saved under a different name is really weird !. :o

Anyway, thank you for the feedback.

Regards.
 
Upvote 0
Hi, Jaafar,

Can you imagine me trying this but not daring to tell it didn't work for me 8-) ? (as you know I never got your "hook"coders to work)
All same symptoms also for me and solved the same way: renaming file.

First time after download got error 57: (not sure how it is in english: I/O device (printer or other apparatus) not working ???)
Downloaded again and then OK.

So for me it works !
I can imagine how to add some code to let the controls stay permanently where they are dragged to... Looks like a potential game :-)

kind regards,
Erik
 
Upvote 0
Hi Erik,

Glad iit worked this time. :) and thanks for the feedback.

Regards.
 
Upvote 0
Hi Jaafar

I too got error 400, changed the name - perfect!!!!

This is on Windows XP SP2, XL 2003.

DominicB
 
Upvote 0

Forum statistics

Threads
1,223,098
Messages
6,170,106
Members
452,302
Latest member
TaMere

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top