Jaafar Tribak
Well-known Member
- Joined
- Dec 5, 2002
- Messages
- 9,806
- Office Version
- 2016
- Platform
- Windows
I have never seen a useful implementation of the little known Hidden DesignMode Property of the userform. here, I show an example that uses it to allow dragging & dropping controls beteween 2 userforms at runtime and allowing the controls to carry their respective Click events with them.
When the forms are first initialized, the dragging and dropping functionality is enabled. To disable this mode, just right click anywhere on each userform and click the menu that pops up .
The controls must be created at runtime otherwise the code errors out.
Workbook demo.
Here is the code in case the above link expires :
1- Add a blank UserForm to your Project and place in it the code below :
2- Add a Standard module and Place this code in it :
When the forms are first initialized, the dragging and dropping functionality is enabled. To disable this mode, just right click anywhere on each userform and click the menu that pops up .
The controls must be created at runtime otherwise the code errors out.
Workbook demo.
Here is the code in case the above link expires :
1- Add a blank UserForm to your Project and place in it the code below :
Code:
Option Explicit
Public WithEvents Btn As MSForms.CommandButton
Public oButton As MSForms.CommandButton
Private sFormIndex As String
Private Sub Btn_Click()
MsgBox "You clicked on: Button " & Btn.Caption
End Sub
Private Sub UserForm_Initialize()
Set oButton = Controls.Add("Forms.CommandButton.1")
Set Btn = oButton
With oButton
.Height = 30
.Width = 30
.Left = Me.InsideWidth / 4
.Top = Me.InsideHeight / 4
.BackColor = vbYellow
.Font.Bold = True
End With
StartUpPosition = 0
If UserForms.Count = 1 Then
oButton.Caption = "B"
sFormIndex = "-(B)"
Caption = Name & sFormIndex
Left = Application.Left + (Application.Width / 2)
Top = Application.Top + (Application.Height / 4)
ElseIf UserForms.Count = 2 Then
oButton.Caption = "A"
oButton.SetFocus
sFormIndex = "-(A)"
Caption = Name & sFormIndex
Top = Application.Top + (Application.Height / 4)
Left = UserForms(1).Width / 2 - UserForms(1).Left
End If
ShowGridDots = fmModeOff
ShowToolbox = fmModeOff
DesignMode = fmModeOn
End Sub
Private Sub UserForm_Deactivate()
Caption = Name & sFormIndex
End Sub
Private Sub UserForm_AddControl(ByVal Control As MSForms.Control)
On Error Resume Next
Set oButton = Control
Caption = Name & sFormIndex
End Sub
Private Sub UserForm_BeforeDragOver(ByVal Cancel As MSForms.ReturnBoolean, _
ByVal Control As MSForms.Control, ByVal Data As MSForms.DataObject, _
ByVal X As Single, ByVal Y As Single, ByVal State As MSForms.fmDragState, _
ByVal Effect As MSForms.ReturnEffect, ByVal Shift As Integer)
On Error Resume Next
If Effect = 0 Then Selected.Clear
If State = fmDragStateOver Then
Caption = "Draging ... Button " & _
Selected.[_GetItemByIndex](0).Caption
End If
End Sub
Private Sub UserForm_BeforeDropOrPaste(ByVal Cancel As MSForms.ReturnBoolean, _
ByVal Control As MSForms.Control, ByVal Action As MSForms.fmAction, _
ByVal Data As MSForms.DataObject, ByVal X As Single, ByVal Y As Single, _
ByVal Effect As MSForms.ReturnEffect, ByVal Shift As Integer)
Dim lPtr As Long
On Error Resume Next
DesignMode = fmModeOff
If Action = fmActionCopy Then
Cancel = True
DesignMode = fmModeOn
Exit Sub
End If
lPtr = ObjPtr(Me)
Application.OnTime Now, "'HookBtn " & lPtr & "'"
DesignMode = fmModeOn
End Sub
Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, _
ByVal X As Single, ByVal Y As Single)
If Selected.Count <> 0 Then
If GetAsyncKeyState(VBA.vbKeyControl) <> 0 Then
DesignMode = fmModeOff
UndoAction
DesignMode = fmModeOn
End If
End If
End Sub
Private Sub UserForm_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, _
ByVal X As Single, ByVal Y As Single)
Dim lPtr As Long
Selected.Clear
If Button = 2 Then
Application.SendKeys "{ESC}"
lPtr = ObjPtr(Me)
Application.OnTime Now, "'CreateRightClickMenu " & lPtr & "'"
End If
End Sub
Code:
Option Explicit
Declare Function GetAsyncKeyState Lib "user32" _
(ByVal vKey As Long) As Integer
Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
pDest As Any, pSrc As Any, ByVal ByteLen As Long)
Private bDragAndDrop As Boolean
Private oCmbarCtl As CommandBarControl
Public Sub ShowTheForms()
Dim oUFrm1 As UserForm1
Dim oUFrm2 As UserForm1
Set oUFrm1 = New UserForm1
Set oUFrm2 = New UserForm1
oUFrm1.Show vbModeless
oUFrm2.Show vbModeless
End Sub
Public Sub HookBtn(ByVal Ptr As Long)
Dim oTempObj As Object
On Error Resume Next
CopyMemory oTempObj, Ptr, 4
With oTempObj
.Selected.Clear
.DesignMode = fmModeOff
Set .oButton = .Selected.[_GetItemByIndex](0)
Set .Btn = .oButton
.DesignMode = fmModeOn
End With
CopyMemory oTempObj, 0&, 4
End Sub
Public Sub CreateRightClickMenu(ByVal Ptr As Long)
Dim objCmb As CommandBar
Dim oTempObj As Object
On Error Resume Next
CommandBars("DesignCmb").Delete
On Error GoTo 0
Set objCmb = Application.CommandBars.Add(, msoBarPopup, , True)
CopyMemory oTempObj, Ptr, 4
With objCmb
.Name = "DesignCmb"
Set oCmbarCtl = .Controls.Add(msoControlButton)
With oCmbarCtl
If oTempObj.DesignMode = fmModeOff Then
bDragAndDrop = True
.Caption = "EnableDrageAndDrop"
Else
.Caption = "DisableDrageAndDrop"
bDragAndDrop = False
End If
.OnAction = "'ToggleDragAndDropMode " & Ptr & "'"
End With
.ShowPopup
End With
CopyMemory oTempObj, 0&, 4
End Sub
Public Sub ToggleDragAndDropMode(ByVal Ptr As Long)
Dim oTempObj As Object
CopyMemory oTempObj, Ptr, 4
Select Case bDragAndDrop
Case True
oTempObj.DesignMode = fmModeOn
oCmbarCtl.Caption = "DisableDrageAndDrop"
Case Else
oTempObj.DesignMode = fmModeOff
oCmbarCtl.Caption = "EnableDrageAndDrop"
End Select
CopyMemory oTempObj, 0&, 4
End Sub
