Jaafar Tribak
Well-known Member
- Joined
- Dec 5, 2002
- Messages
- 9,797
- Office Version
- 2016
- Platform
- Windows
This little project took me hours and hours to complete but I think was worthy if only for the learning experience.
The project as such won't be of much use to most excel users but its shows that vba can do all kinds of neat things when combined with the win32 API.
This is what the code does:
* Allows moving and\or copying userform controls at runtime.
* The semi-transparent control that follows the mouse pointer during a dragging operation is actually a win32 static control (This static control, not being a child window of the userform, was the most tricky part to make it a layered window and to keep it confined within the bounderies of the parent form.)
* A colored dashed frame is drawn around the static control.
* The cursor changes dynamically depending on moving the controls , copying them (Holding CTRL key down) or when -the image is being moved outside the parent form. (custom cursor not showing on the Gif below but works as expected in the file demo below)
* Right-click context menu for deleting the controls.
* A label control can optionally be integrated into the class for displaying the current user activity.
This is the signature of only Class Method that hooks the UserForm controls:
Public Sub HookControl( _
ByVal ThisClassInstance As cls_DraggableControl, _
ByVal Ctrl As Control, _
Optional ByVal UILabel As Control _
)
Note: The transparency of the static control won't work unless the Desktop Window Manager (DWM) is enabled in the machine running the code.
Workbook Demo
1- Class code (Cls_DraggableControl):
2- Code Usage example (Standard Module )
The project as such won't be of much use to most excel users but its shows that vba can do all kinds of neat things when combined with the win32 API.
This is what the code does:
* Allows moving and\or copying userform controls at runtime.
* The semi-transparent control that follows the mouse pointer during a dragging operation is actually a win32 static control (This static control, not being a child window of the userform, was the most tricky part to make it a layered window and to keep it confined within the bounderies of the parent form.)
* A colored dashed frame is drawn around the static control.
* The cursor changes dynamically depending on moving the controls , copying them (Holding CTRL key down) or when -the image is being moved outside the parent form. (custom cursor not showing on the Gif below but works as expected in the file demo below)
* Right-click context menu for deleting the controls.
* A label control can optionally be integrated into the class for displaying the current user activity.
This is the signature of only Class Method that hooks the UserForm controls:
Public Sub HookControl( _
ByVal ThisClassInstance As cls_DraggableControl, _
ByVal Ctrl As Control, _
Optional ByVal UILabel As Control _
)
Note: The transparency of the static control won't work unless the Desktop Window Manager (DWM) is enabled in the machine running the code.
Workbook Demo
1- Class code (Cls_DraggableControl):
VBA Code:
Option Explicit
Private Enum eCursor
Drag_Cursor = 0
Copy_Cursor = 1
No_Cursor = 2
End Enum
Private Type POINTAPI
X As Long
Y As Long
End Type
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type uPicDesc
Size As Long
Type As Long
#If Win64 Then
hPic As LongLong
hPal As LongLong
#Else
hPic As Long
hPal As Long
#End If
End Type
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Private Type LOGPEN
lopnStyle As Long
lopnWidth As POINTAPI
lopnColor As Long
End Type
Private Type LOGBRUSH
lbStyle As Long
lbColor As Long
#If Win64 Then
lbHatch As LongLong
#Else
lbHatch As Long
#End If
End Type
Private Type GdiplusStartupInput
GdiplusVersion As Long
#If Win64 Then
DebugEventCallback As LongLong
SuppressBackgroundThread As LongLong
#Else
DebugEventCallback As Long
SuppressBackgroundThread As Long
#End If
SuppressExternalCodecs As Long
End Type
#If VBA7 Then
#If Win64 Then
Private Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal Point As LongPtr) As LongLong
Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongPtrA" (ByVal hwnd As LongLong, ByVal nIndex As Long, ByVal dwNewLong As LongLong) As LongLong
#Else
Private Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As LongPtr
Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As Long) As LongPtr
#End If
Private Declare PtrSafe Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As LongPtr, ByVal hMenu As LongPtr, ByVal hInstance As LongPtr, lpParam As Any) As LongPtr
Private Declare PtrSafe Function DestroyWindow Lib "user32" (ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As LongPtr
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare PtrSafe Function SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As LongPtr, ByVal crey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As LongPtr
Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare PtrSafe Function CopyImage Lib "user32" (ByVal handle As LongPtr, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As LongPtr
Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
Private Declare PtrSafe Function ScreenToClient Lib "user32" (ByVal hwnd As LongPtr, lpPoint As POINTAPI) As Long
Private Declare PtrSafe Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hdc As LongPtr, ByVal nIndex As Long) As Long
Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hdc As LongPtr) As Long
Private Declare PtrSafe Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function IsChild Lib "user32" (ByVal hWndParent As LongPtr, ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Private Declare PtrSafe Function DestroyIcon Lib "user32" (ByVal hIcon As LongPtr) As Long
Private Declare PtrSafe Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As LongPtr
Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hdc As LongPtr, ByVal hObject As LongPtr) As LongPtr
Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
Private Declare PtrSafe Function SetActiveWindow Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
Private Declare PtrSafe Function GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hwnd As LongPtr, ByVal wFlag As Long) As LongPtr
Private Declare PtrSafe Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As LongPtr
Private Declare PtrSafe Function SetWindowRgn Lib "user32" (ByVal hwnd As LongPtr, ByVal hRgn As LongPtr, ByVal bRedraw As Long) As Long
Private Declare PtrSafe Function SetWindowPos Lib "user32" (ByVal hwnd As LongPtr, ByVal hWndInsertAfter As LongPtr, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Declare PtrSafe Function IntersectRect Lib "user32" (lpDestRect As RECT, lpSrc1Rect As RECT, lpSrc2Rect As RECT) As Long
Private Declare PtrSafe Function IsRectEmpty Lib "user32" (lpRect As RECT) As Long
Private Declare PtrSafe Function DwmGetWindowAttribute Lib "Dwmapi.dll" (ByVal hwnd As LongPtr, ByVal dwAttribute As Long, ByRef pvAttribute As Any, ByVal cbAttribute As Long) As Long
Private Declare PtrSafe Function ExtCreatePen Lib "gdi32" (ByVal dwPenStyle As Long, ByVal dwWidth As Long, lplb As LOGBRUSH, ByVal dwStyleCount As Long, lpStyle As Long) As LongPtr
Private Declare PtrSafe Function Rectangle Lib "gdi32" (ByVal hdc As LongPtr, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare PtrSafe Function GetStockObject Lib "gdi32" (ByVal nIndex As Long) As LongPtr
Private Declare PtrSafe Function CreateIconFromResourceEx Lib "user32.dll" (ByRef presbits As Any, ByVal dwResSize As Long, ByVal fIcon As Long, ByVal dwVer As Long, ByVal cxDesired As Long, ByVal cyDesired As Long, ByVal Flags As Long) As LongPtr
Private Declare PtrSafe Function SetCursorAPI Lib "user32" Alias "SetCursor" (ByVal hCursor As LongPtr) As LongPtr
Private Declare PtrSafe Function LoadCursor Lib "user32" Alias "LoadCursorA" (ByVal hInstance As LongPtr, ByVal lpCursorName As Long) As Long
Private Declare PtrSafe Function OleCreatePictureIndirect Lib "oleAut32.dll" (PicDesc As uPicDesc, RefIID As Any, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
Private Declare PtrSafe Function CreatePopupMenu Lib "user32" () As LongPtr
Private Declare PtrSafe Function DestroyMenu Lib "user32" (ByVal hMenu As LongPtr) As Long
Private Declare PtrSafe Function AppendMenu Lib "user32" Alias "AppendMenuA" (ByVal hMenu As LongPtr, ByVal wFlags As Long, ByVal wIDNewItem As LongPtr, ByVal lpNewItem As Any) As Long
Private Declare PtrSafe Function TrackPopupMenuEx Lib "user32" (ByVal hMenu As LongPtr, ByVal un As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal hwnd As LongPtr, ByVal lpTPMParams As Long) As Long
Private Declare PtrSafe Function SetMenuItemBitmaps Lib "user32" (ByVal hMenu As LongPtr, ByVal nPosition As Long, ByVal wFlags As Long, ByVal hBitmapUnchecked As LongPtr, ByVal hBitmapChecked As LongPtr) As Long
Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As LongPtr
'GDI+
Private Declare PtrSafe Function GdiplusStartup Lib "gdiplus" (token As LongPtr, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As Long
Private Declare PtrSafe Function GdiplusShutdown Lib "gdiplus" (ByVal token As LongPtr) As Long
Private Declare PtrSafe Function GdipCreateBitmapFromHBITMAP Lib "gdiplus" (ByVal hbm As LongPtr, ByVal hPal As LongPtr, BITMAP As LongPtr) As Long
Private Declare PtrSafe Function GdipDisposeImage Lib "gdiplus" (ByVal Image As LongPtr) As LongPtr
Private Declare PtrSafe Function GdipCreateHBITMAPFromBitmap Lib "gdiplus" (ByVal BITMAP As LongPtr, hbmReturn As LongPtr, ByVal background As Long) As Long
Private Declare PtrSafe Function GdipGetImageThumbnail Lib "gdiplus" (ByVal Image As LongPtr, ByVal thumbWidth As Long, ByVal thumbHeight As Long, thumbImage As LongPtr, ByVal Callback As LongPtr, ByVal callbackData As LongPtr) As Long
Private hBitmap As LongPtr, hCopy As LongPtr
#Else
Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long
Private Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As Long, ByVal crey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function CopyImage Lib "user32" (ByVal handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function ScreenToClient Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hwnd As Long) As Long
Private Declare Function IsChild Lib "user32" (ByVal hWndParent As Long, ByVal hwnd As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Private Declare Function DestroyIcon Lib "user32" (ByVal hIcon As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function SetActiveWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hwnd As Long, ByVal wFlag As Long) As Long
Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function SetWindowRgn Lib "user32" (ByVal hwnd As Long, ByVal hRgn As Long, ByVal bRedraw As Long) As Long
Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Declare Function IntersectRect Lib "user32" (lpDestRect As RECT, lpSrc1Rect As RECT, lpSrc2Rect As RECT) As Long
Private Declare Function IsRectEmpty Lib "user32" (lpRect As RECT) As Long
Private Declare Function DwmGetWindowAttribute Lib "Dwmapi.dll" (ByVal hwnd As Long, ByVal dwAttribute As Long, ByRef pvAttribute As Any, ByVal cbAttribute As Long) As Long
Private Declare Function ExtCreatePen Lib "gdi32" (ByVal dwPenStyle As Long, ByVal dwWidth As Long, lplb As LOGBRUSH, ByVal dwStyleCount As Long, lpStyle As Long) As Long
Private Declare Function Rectangle Lib "gdi32" (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function GetStockObject Lib "gdi32" (ByVal nIndex As Long) As Long
Private Declare Function CreateIconFromResourceEx Lib "User32.dll" (ByRef presbits As Any, ByVal dwResSize As Long, ByVal fIcon As Long, ByVal dwVer As Long, ByVal cxDesired As Long, ByVal cyDesired As Long, ByVal Flags As Long) As Long
Private Declare Function SetCursorAPI Lib "user32" Alias "SetCursor" (ByVal hCursor As Long) As Long
Private Declare Function LoadCursor Lib "user32" Alias "LoadCursorA" (ByVal hInstance As Long, ByVal lpCursorName As Long) As Long
Private Declare Function OleCreatePictureIndirect Lib "oleAut32.dll" (PicDesc As uPicDesc, RefIID As Any, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
Private Declare Function CreatePopupMenu Lib "user32" () As Long
Private Declare Function DestroyMenu Lib "user32" (ByVal hMenu As Long) As Long
Private Declare Function AppendMenu Lib "user32" Alias "AppendMenuA" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpNewItem As Any) As Long
Private Declare Function TrackPopupMenuEx Lib "user32" (ByVal hMenu As Long, ByVal un As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal hwnd As Long, ByVal lpTPMParams As Long) As Long
Private Declare Function SetMenuItemBitmaps Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long, ByVal hBitmapUnchecked As Long, ByVal hBitmapChecked As Long) As Long
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
'GDI+
Private Declare Function GdiplusStartup Lib "gdiplus" (token As Long, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As Long
Private Declare Function GdiplusShutdown Lib "gdiplus" (ByVal token As Long) As Long
Private Declare Function GdipCreateBitmapFromHBITMAP Lib "gdiplus" (ByVal hbm As Long, ByVal hPal As Long, BITMAP As Long) As Long
Private Declare Function GdipDisposeImage Lib "gdiplus" (ByVal Image As Long) As Long
Private Declare Function GdipCreateHBITMAPFromBitmap Lib "gdiplus" (ByVal BITMAP As Long, hbmReturn As Long, ByVal background As Long) As Long
Private Declare Function GdipGetImageThumbnail Lib "gdiplus" (ByVal Image As Long, ByVal thumbWidth As Long, ByVal thumbHeight As Long, thumbImage As Long, ByVal Callback As Long, ByVal callbackData As Long) As Long
Private hBitmap As Long, hCopy As Long
#End If
Private bMouseDragging As Boolean
Private oNewClass As cls_DraggableControl
Private oThisInstance As cls_DraggableControl
Private oContainers As Collection
Private lCtrlWidth As Long, lCtrlHeight As Long
Private oUILabel As Control
Private WithEvents Cntrl As MSForms.Image
'___________________________________Class Public Method________________________________________________
Public Sub HookControl(ByVal ThisClassInstance As cls_DraggableControl, ByVal Ctrl As Control, Optional ByVal UILabel As Control)
Const CHILDID_SELF = &H0&
#If Win64 Then
Dim hwnd As LongLong
#Else
Dim hwnd As Long
#End If
Dim oForm As Object
Dim oCtrl As Control
Set oThisInstance = ThisClassInstance
Set oForm = GetUserFormObject(Ctrl)
If oContainers Is Nothing Then
Set oContainers = New Collection
IUnknown_GetWindow oForm, VarPtr(hwnd)
oContainers.Add oForm, CStr(GetNextWindow(hwnd, 5))
For Each oCtrl In oForm.Controls
If TypeOf oCtrl Is MSForms.Frame Then
oContainers.Add oCtrl, CStr(oCtrl.[_GethWnd])
End If
Next oCtrl
End If
Set Cntrl = Ctrl
If Not UILabel Is Nothing Then
Set oUILabel = UILabel
End If
End Sub
'___________________________________Class Private Routines________________________________________________
Private Sub Cntrl_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If Button = 2 Then
Call CreateAndShowContextMenu
End If
End Sub
Private Sub Cntrl_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If Button = 1 And bMouseDragging = False Then
Call DragControl(CreateWindow(Cntrl), Cntrl, X, Y)
End If
End Sub
#If Win64 Then
Private Function CreateWindow( _
ByVal Cntrl As Control _
) As LongLong
#Else
Private Function CreateWindow( _
ByVal Cntrl As Control _
) As Long
#End If
Const WS_POPUP = &H80000000
Const SS_BITMAP = &HE
Const IMAGE_BITMAP = &H0
Const STM_SETIMAGE = &H172
Const WS_EX_TOPMOST = &H8
Const WS_EX_LAYERED = &H80000
Const WS_EX_NOACTIVATE = &H8000000
Const GWL_HWNDPARENT = (-8)
Const GW_CHILD = &H5
Const LWA_ALPHA = &H2&
#If Win64 Then
Dim hForm As LongPtr, hStatic As LongPtr
#Else
Dim hForm As Long, hStatic As Long
#End If
lCtrlWidth = PTtoPX(Cntrl.Width, False)
lCtrlHeight = PTtoPX(Cntrl.Height, True)
hStatic = CreateWindowEx(WS_EX_LAYERED + WS_EX_NOACTIVATE + WS_EX_TOPMOST, _
"STATIC", "", WS_POPUP Or SS_BITMAP, 0, 0, _
0, 0, 0, 0&, GetModuleHandle(vbNullString), 0&)
Call SetLayeredWindowAttributes(hStatic, 0, 100, LWA_ALPHA)
Call IUnknown_GetWindow(GetUserFormObject(Cntrl), VarPtr(hForm))
Call SetWindowLong(hStatic, GWL_HWNDPARENT, hForm)
hBitmap = CreateAndResizeBitmap(Cntrl.Picture, lCtrlWidth, lCtrlHeight)
Call SendMessage(hStatic, STM_SETIMAGE, IMAGE_BITMAP, ByVal hBitmap)
Call SetActiveWindow(hForm)
CreateWindow = hStatic
End Function
#If Win64 Then
Private Sub DragControl( _
ByVal hStatic As LongLong, _
ByVal Ctrl As Control, _
ByVal X As Single, _
ByVal Y As Single _
)
Dim hStaticRgn As LongLong, hStaticDC As LongLong, hContainer As LongLong
#Else
Private Sub DragControl( _
ByVal hStatic As Long, _
ByVal Ctrl As Control, _
ByVal X As Single, _
ByVal Y As Single _
)
Dim hStaticRgn As Long, hStaticDC As Long, hContainer As Long
#End If
Const SWP_SHOWWINDOW = &H40
Const SWP_NOACTIVATE = &H10
Const CHILDID_SELF = &H0&
Dim oContainer As Object, lIndex As Long
Dim tDstRect As RECT, tPt1 As POINTAPI, tPt2 As POINTAPI
Dim tFormRect As RECT, tStaticRect As RECT, tCursPos As POINTAPI
Do While GetAsyncKeyState(vbKeyLButton)
bMouseDragging = True
tFormRect = Get_Form_Extended_Frame_Bounds_Rectangle(GetUserFormObject(Ctrl))
Call GetWindowRect(hStatic, tStaticRect)
Call IntersectRect(tDstRect, tFormRect, tStaticRect)
With tDstRect
tPt1.X = .Left
tPt1.Y = .Top
tPt2.X = .Right
tPt2.Y = .Bottom
End With
Call ScreenToClient(hStatic, tPt1)
Call ScreenToClient(hStatic, tPt2)
hStaticRgn = CreateRectRgn(tPt1.X, tPt1.Y, tPt2.X, tPt2.Y)
hStaticDC = GetDC(hStatic)
Call MakeStaticBorder(hStaticDC)
Call SetWindowRgn(hStatic, hStaticRgn, True)
Call ReleaseDC(hStatic, hStaticDC)
' Call DeleteObject(hStaticRgn) ' !!
Call GetCursorPos(tCursPos)
Call SetWindowPos( _
hStatic, 0, tCursPos.X - PTtoPX(X, False), tCursPos.Y - PTtoPX(Y, True), _
lCtrlWidth, lCtrlHeight, SWP_NOACTIVATE + SWP_SHOWWINDOW)
#If Win64 Then
Dim lPT As LongLong
Call CopyMemory(lPT, tCursPos, LenB(lPT))
hContainer = WindowFromPoint(lPT)
#Else
hContainer = WindowFromPoint(tCursPos.X, tCursPos.Y)
#End If
For lIndex = 1 To oContainers.Count
On Error Resume Next
Set oContainer = oContainers(CStr(hContainer))
On Error GoTo 0
If Not oContainer Is Nothing Then
Exit For
End If
Next lIndex
If IsRectEmpty(tDstRect) Then
SetCursor = No_Cursor
If Not oUILabel Is Nothing Then
oUILabel.Caption = "Outside UserForm."
End If
Else
If GetAsyncKeyState(VBA.vbKeyControl) Then
SetCursor = Copy_Cursor
If Not oUILabel Is Nothing Then
oUILabel.Caption = "Copying Control."
End If
Else
SetCursor = Drag_Cursor
If Not oUILabel Is Nothing Then
oUILabel.Caption = "Moving Control."
End If
End If
End If
DoEvents
Loop
bMouseDragging = False
Call DeleteObject(hCopy)
Call DeleteObject(hBitmap)
If IsRectEmpty(tDstRect) = 0 Then
Call RelocateControl(Ctrl, hStatic, oContainer)
Call DestroyWindow(hStatic)
End If
End Sub
#If Win64 Then
Private Sub RelocateControl( _
ByVal Ctrl As Control, _
ByVal StaticHwnd As LongLong, _
ByVal Container As Object _
)
Dim hContainer As LongLong, hForm As LongLong
#Else
Private Sub RelocateControl( _
ByVal Ctrl As Control, _
ByVal StaticHwnd As Long, _
ByVal Container As Object _
)
Dim hContainer As Long, hForm As Long
#End If
Const WM_SETREDRAW = &HB
Const SM_CYCAPTION = 4
Const SM_CYDLGFRAME = 8
Const SM_CYBORDER = 6
Const SM_CXEDGE = 45
Const SM_CYEDGE = 46
Const SM_CYFRAME = 33
Dim oNewControl As Control
Dim lFrameHOffset As Long, lFrameVOffset As Long
Dim tStaticRect As RECT, tCursPos As POINTAPI
On Error GoTo xit
Call IUnknown_GetWindow(Container, VarPtr(hContainer))
Call IUnknown_GetWindow(GetUserFormObject(Ctrl), VarPtr(hForm))
Call SendMessage(hContainer, ByVal WM_SETREDRAW, ByVal 0, 0)
Select Case GetAsyncKeyState(VBA.vbKeyControl)
Case 0 'moving.
If Cntrl.Parent Is Container Then
Set oNewControl = Cntrl
If Not oUILabel Is Nothing Then
oUILabel.Caption = Ctrl.Name & " moved."
End If
Else
Cntrl.Visible = False
Set oNewControl = AddNewControl(Container)
oNewControl.Name = Cntrl.Name
If Not oUILabel Is Nothing Then
oUILabel.Caption = Ctrl.Name & " moved."
End If
End If
Case Else 'copying.
Set oNewControl = AddNewControl(Container)
If Not oUILabel Is Nothing Then
oUILabel.Caption = Ctrl.Name & " copied."
End If
End Select
lFrameHOffset = GetSystemMetrics(SM_CXEDGE)
lFrameVOffset = GetSystemMetrics(SM_CYEDGE) + _
GetSystemMetrics(SM_CYFRAME) + GetSystemMetrics(SM_CYBORDER)
Call GetWindowRect(StaticHwnd, tStaticRect)
Call GetCursorPos(tCursPos)
tCursPos.X = tStaticRect.Left: tCursPos.Y = tStaticRect.Top
Call ScreenToClient(hContainer, tCursPos)
With oNewControl
.Left = PXtoPT(tCursPos.X - IIf(IsChild(hForm, hContainer), lFrameHOffset, 0), False)
.Top = PXtoPT(tCursPos.Y - IIf(IsChild(hForm, hContainer), lFrameVOffset, 0), True)
.Width = Cntrl.Width
.Height = Cntrl.Height
.PictureSizeMode = fmPictureSizeModeStretch
.Picture = Cntrl.Picture
End With
xit:
Call SendMessage(hContainer, ByVal WM_SETREDRAW, ByVal 1, 0)
Container.Repaint
End Sub
Private Function AddNewControl(ByVal Container As Object, Optional ByVal UILabel As Control) As Control
Dim oNewCtrl As Control
Set AddNewControl = Container.Controls.Add("Forms.Image.1")
Set oNewClass = New cls_DraggableControl
oNewClass.HookControl oNewClass, AddNewControl, oUILabel
End Function
#If Win64 Then
Private Sub MakeStaticBorder( _
ByVal hdc As LongLong _
)
Dim hPrevBrush As LongLong, hBrush As LongLong, hPrevPen As LongLong, hPen As LongLong
#Else
Private Sub MakeStaticBorder( _
ByVal hdc As Long _
)
Dim hPrevBrush As Long, hBrush As Long, hPrevPen As Long, hPen As Long
#End If
Const DASH_LEN = 5
Const SPACE_LEN = 10
Const PEN_WIDTH = 4
Const HOLLOW_BRUSH = 5
Const PEN_COLOR = vbRed
Const BS_SOLID = 0
Const PS_GEOMETRIC = &H10000
Const PS_USERSTYLE = 7&
Dim LOGBRUSH As LOGBRUSH
Dim lStyleArray(1) As Long
With LOGBRUSH
.lbStyle = BS_SOLID
.lbColor = PEN_COLOR
End With
lStyleArray(0) = DASH_LEN
lStyleArray(1) = SPACE_LEN
hPen = ExtCreatePen(PS_GEOMETRIC Or PS_USERSTYLE, PEN_WIDTH, LOGBRUSH, 2, lStyleArray(0))
hBrush = GetStockObject(HOLLOW_BRUSH)
hPrevBrush = SelectObject(hdc, hBrush)
hPrevPen = SelectObject(hdc, hPen)
Call Rectangle(hdc, 0, 0, lCtrlWidth, lCtrlHeight)
Call SelectObject(hdc, hPrevPen)
Call SelectObject(hdc, hPrevBrush)
Call DeleteObject(hPen)
Call DeleteObject(hBrush)
End Sub
Private Sub CreateAndShowContextMenu()
Const MF_STRING = &H0&
Const MF_BYPOSITION = &H400
Const TPM_RETURNCMD = &H100&
#If Win64 Then
Dim hMenu As LongLong, hwnd As LongLong
#Else
Dim hMenu As Long, hwnd As Long
#End If
Dim lShowPopupMenu As Long
Dim oFaceIdPic As StdPicture, tCursPos As POINTAPI
hMenu = CreatePopupMenu()
If hMenu Then
Call AppendMenu(hMenu, MF_STRING, 1, "&Remove")
Set oFaceIdPic = PicFromFaceID(478)
If Not oFaceIdPic Is Nothing Then
Call SetMenuItemBitmaps(hMenu, 0, MF_BYPOSITION, oFaceIdPic, oFaceIdPic)
End If
Call IUnknown_GetWindow(GetUserFormObject(Cntrl), VarPtr(hwnd))
Call GetCursorPos(tCursPos)
lShowPopupMenu = TrackPopupMenuEx(hMenu, TPM_RETURNCMD, tCursPos.X, tCursPos.Y, hwnd, ByVal 0&)
If lShowPopupMenu = 1 Then Cntrl.Visible = False
Call DestroyMenu(hMenu)
If Not oUILabel Is Nothing Then
oUILabel.Caption = Cntrl.Name & " Deleted."
End If
End If
End Sub
Private Function ScreenDPI(ByVal bVert As Boolean) As Long
#If Win64 Then
Dim hdc As LongLong
#Else
Dim hdc As Long
#End If
Const LOGPIXELSX As Long = 88
Const LOGPIXELSY As Long = 90
Static lDPI(1) As Long
If lDPI(0) = 0 Then
hdc = GetDC(0)
lDPI(0) = GetDeviceCaps(hdc, LOGPIXELSX)
lDPI(1) = GetDeviceCaps(hdc, LOGPIXELSY)
ReleaseDC 0, hdc
End If
ScreenDPI = lDPI(Abs(bVert))
End Function
Private Function PTtoPX(ByVal Points As Single, ByVal bVert As Boolean) As Long
Const POINTSPERINCH As Long = 72
PTtoPX = Points * ScreenDPI(bVert) / POINTSPERINCH
End Function
Private Function PXtoPT(ByVal Pixels As Long, ByVal bVert As Boolean) As Long
Const POINTSPERINCH As Long = 72
PXtoPT = Pixels / (ScreenDPI(bVert) / POINTSPERINCH)
End Function
Private Function GetUserFormObject(ByVal Ctrl As Control) As Object
Dim oTemp As Object
Set oTemp = Ctrl.Parent
Do While TypeOf oTemp Is MSForms.Control
Set oTemp = oTemp.Parent
DoEvents
Loop
Set GetUserFormObject = oTemp
End Function
Private Function PicFromFaceID(ByVal FaceID As Long) As IPicture
#If Win64 Then
Dim hPtr As LongLong
#Else
Dim hPtr As Long
#End If
Const S_OK = &H0
Const CF_BITMAP = 2
Const IMAGE_BITMAP = 0
Const LR_COPYRETURNORG = &H4
Const PICTYPE_BITMAP = 1
Dim iPic As IPicture
Dim IID_IDispatch As GUID, uPicinfo As uPicDesc
On Error GoTo errHandler
Application.CommandBars.FindControl(id:=FaceID).CopyFace
Call OpenClipboard(0)
hPtr = GetClipboardData(CF_BITMAP)
If hPtr Then
hPtr = CopyImage(hPtr, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
Call EmptyClipboard
Call CloseClipboard
With IID_IDispatch
.Data1 = &H20400
.Data4(0) = &HC0
.Data4(7) = &H46
End With
With uPicinfo
.Size = Len(uPicinfo)
.Type = PICTYPE_BITMAP
.hPic = hPtr
.hPal = 0
End With
If OleCreatePictureIndirect(uPicinfo, IID_IDispatch, True, iPic) = S_OK Then
Set PicFromFaceID = iPic
End If
End If
Exit Function
errHandler:
Call EmptyClipboard
Call CloseClipboard
End Function
Private Function Get_Form_Extended_Frame_Bounds_Rectangle(ByVal Form As Object) As RECT
Const SM_CYCAPTION = 4
Const SM_CYDLGFRAME = 8
Const SM_CYBORDER = 6
Const SM_CXEDGE = 45
Const SM_CYEDGE = 46
Const SM_CYFRAME = 33
Const DWMWA_EXTENDED_FRAME_BOUNDS = 9
#If Win64 Then
Dim hForm As LongLong
#Else
Dim hForm As Long
#End If
Dim tRect As RECT, tFormRect As RECT
Call IUnknown_GetWindow(Form, VarPtr(hForm))
Call DwmGetWindowAttribute(hForm, DWMWA_EXTENDED_FRAME_BOUNDS, tFormRect, LenB(tFormRect))
Call GetWindowRect(hForm, tRect)
If tFormRect.Right = 0 Then
With tRect
.Top = .Top + GetSystemMetrics(SM_CYCAPTION) + GetSystemMetrics(SM_CYDLGFRAME)
End With
tFormRect = tRect
Else
With tFormRect
.Top = .Top + GetSystemMetrics(SM_CYCAPTION) + GetSystemMetrics(SM_CYDLGFRAME) _
+ GetSystemMetrics(SM_CYFRAME) + GetSystemMetrics(SM_CYBORDER)
End With
End If
Get_Form_Extended_Frame_Bounds_Rectangle = tFormRect
End Function
#If Win64 Then
Private Function BuildDrag_Cursor() As LongLong
#Else
Private Function BuildDrag_Cursor() As Long
#End If
ReDim longs(0 To 186) As Long
longs(0) = 0: longs(1) = 40: longs(2) = 32: longs(3) = 64: longs(4) = 262145: longs(5) = 0: longs(6) = 640: longs(7) = 0: longs(8) = 0: longs(9) = 16: longs(10) = 0: longs(11) = 0: longs(12) = 8388608: longs(13) = 32768: longs(14) = 8421376: longs(15) = 128: longs(16) = 8388736: longs(17) = 32896: longs(18) = 12632256: longs(19) = 8421504: longs(20) = 16711680: longs(21) = 65280: longs(22) = 16776960: longs(23) = 255: longs(24) = 16711935: longs(25) = 65535: longs(26) = 16777215: longs(27) = 0: longs(28) = 0: longs(29) = 0
longs(30) = 0: longs(31) = 0: longs(32) = 0: longs(33) = 0: longs(34) = 0: longs(35) = 0: longs(36) = 151587072: longs(37) = 151587081: longs(38) = 9: longs(39) = 0: longs(40) = -1869611008: longs(41) = -1869574000: longs(42) = 144: longs(43) = 0: longs(44) = 2304: longs(45) = 0: longs(46) = 9: longs(47) = 0: longs(48) = 9437184: longs(49) = 0: longs(50) = 144: longs(51) = 0: longs(52) = 2304: longs(53) = 0: longs(54) = 9: longs(55) = 0: longs(56) = 9437184: longs(57) = 0: longs(58) = 144: longs(59) = 0
longs(60) = 2304: longs(61) = 0: longs(62) = 9: longs(63) = 0: longs(64) = 9437184: longs(65) = 0: longs(66) = 144: longs(67) = 0: longs(68) = 2304: longs(69) = 0: longs(70) = 9: longs(71) = 0: longs(72) = -1869611008: longs(73) = -1869574000: longs(74) = 144: longs(75) = 0: longs(76) = 151587072: longs(77) = 151587081: longs(78) = 9: longs(79) = 150994944: longs(80) = 144: longs(81) = 0: longs(82) = 0: longs(83) = -1728053248: longs(84) = 153: longs(85) = 0: longs(86) = 0: longs(87) = -1728053248: longs(88) = 153: longs(89) = 0
longs(90) = 0: longs(91) = -1727463424: longs(92) = 144: longs(93) = 0: longs(94) = 0: longs(95) = -1727463280: longs(96) = 144: longs(97) = 0: longs(98) = 0: longs(99) = -1718026087: longs(100) = 0: longs(101) = 0: longs(102) = 0: longs(103) = -1717989223: longs(104) = 0: longs(105) = 0: longs(106) = 0: longs(107) = -1868981863: longs(108) = 0: longs(109) = 0: longs(110) = 0: longs(111) = -1717986919: longs(112) = 37017: longs(113) = 0: longs(114) = 0: longs(115) = -1717986919: longs(116) = 153: longs(117) = 0: longs(118) = 0: longs(119) = -1717986919
longs(120) = 144: longs(121) = 0: longs(122) = 0: longs(123) = -1717986919: longs(124) = 0: longs(125) = 0: longs(126) = 0: longs(127) = -1868981863: longs(128) = 0: longs(129) = 0: longs(130) = 0: longs(131) = 10066329: longs(132) = 0: longs(133) = 0: longs(134) = 0: longs(135) = 9476505: longs(136) = 0: longs(137) = 0: longs(138) = 0: longs(139) = 39321: longs(140) = 0: longs(141) = 0: longs(142) = 0: longs(143) = 37017: longs(144) = 0: longs(145) = 0: longs(146) = 0: longs(147) = 153: longs(148) = 0: longs(149) = 0
longs(150) = 0: longs(151) = 144: longs(152) = 0: longs(153) = 0: longs(154) = 0: longs(155) = -1: longs(156) = -1: longs(157) = -1079317761: longs(158) = 2136339967: longs(159) = -1073745921: longs(160) = 2147481599: longs(161) = -1073745921: longs(162) = 2147481599: longs(163) = -1073745921: longs(164) = 2147481599: longs(165) = -1073745921: longs(166) = 2136339967: longs(167) = -1079317761: longs(168) = -32770: longs(169) = -49156: longs(170) = -49156: longs(171) = -32776: longs(172) = -32904: longs(173) = -208: longs(174) = -240: longs(175) = -255: longs(176) = -57600: longs(177) = -49408: longs(178) = -33024: longs(179) = -256
longs(180) = -255: longs(181) = -253: longs(182) = -249: longs(183) = -241: longs(184) = -225: longs(185) = -193: longs(186) = -129:
BuildDrag_Cursor = CreateIconFromResourceEx(longs(0), UBound(longs) * 4 + 4, 0&, &H30000, 0, 0, 0&)
End Function
#If Win64 Then
Private Function BuildCopy_Cursor() As LongLong
#Else
Private Function BuildCopy_Cursor() As Long
#End If
ReDim longs(0 To 186) As Long
longs(1) = 40: longs(2) = 32: longs(3) = 64: longs(4) = 262145: longs(6) = 640: longs(9) = 16: longs(10) = 16: longs(12) = 8388608: longs(13) = 32768: longs(14) = 8421376: longs(15) = 128: longs(16) = 8388736: longs(17) = 32896: longs(18) = 8421504: longs(19) = 12632256: longs(20) = 16711680: longs(21) = 65280: longs(22) = 16776960: longs(23) = 255: longs(24) = 16711935: longs(25) = 65535: longs(26) = 16777215:
longs(36) = 151587072: longs(37) = 151587081: longs(38) = 9: longs(40) = -1869611008: longs(41) = -1869574000: longs(42) = 144: longs(44) = 2304: longs(46) = 9: longs(48) = 9437184: longs(50) = 144: longs(52) = 2304: longs(54) = 9: longs(56) = 9437184: longs(58) = 144:
longs(60) = 2304: longs(62) = 9: longs(64) = 9437184: longs(66) = 144: longs(68) = 2304: longs(70) = 9: longs(72) = -1869611008: longs(73) = -1869574000: longs(74) = 144: longs(76) = 151587072: longs(77) = 151587081: longs(78) = 9: longs(79) = 150994944: longs(80) = 144: longs(83) = -1728053248: longs(84) = 153: longs(87) = -1728053248: longs(88) = 153: longs(89) = 37017
longs(91) = -1727463424: longs(92) = 144: longs(93) = 37017: longs(95) = -1727463280: longs(96) = 144: longs(97) = 37017: longs(99) = -1718026087: longs(100) = -1861681152: longs(101) = 10064281: longs(103) = -1717989223: longs(104) = -1727463424: longs(105) = 10066329: longs(107) = -1868981863: longs(108) = -1727463424: longs(109) = 10066321: longs(111) = -1717986919: longs(112) = 37017: longs(113) = 37017: longs(115) = -1717986919: longs(116) = 153: longs(117) = 37017: longs(119) = -1717986919
longs(120) = 144: longs(121) = 37017: longs(123) = -1717986919: longs(127) = -1868981863: longs(131) = 10066329: longs(135) = 9476505: longs(139) = 39321: longs(143) = 37017: longs(147) = 153:
longs(151) = 144: longs(155) = -1: longs(156) = -1: longs(157) = -1079317761: longs(158) = 2136339967: longs(159) = -1073745921: longs(160) = 2147481599: longs(161) = -1073745921: longs(162) = 2147481599: longs(163) = -1073745921: longs(164) = 2147481599: longs(165) = -1073745921: longs(166) = 2136339967: longs(167) = -1079317761: longs(168) = -32770: longs(169) = -49156: longs(170) = -14729220: longs(171) = -14712840: longs(172) = -14712968: longs(173) = -16517072: longs(174) = -16517104: longs(175) = -16517119: longs(176) = -14737664: longs(177) = -14729472: longs(178) = -14713088: longs(179) = -256
longs(180) = -255: longs(181) = -253: longs(182) = -249: longs(183) = -241: longs(184) = -225: longs(185) = -193: longs(186) = -129:
BuildCopy_Cursor = CreateIconFromResourceEx(longs(0), UBound(longs) * 4 + 4, 0&, &H30000, 0, 0, 0&)
End Function
Private Property Let SetCursor(Cur As eCursor)
Const IDC_NO = 32648&
#If Win64 Then
Dim hCursor As LongLong
#Else
Dim hCursor As Long
#End If
Select Case Cur
Case Drag_Cursor
hCursor = BuildDrag_Cursor
Case Copy_Cursor
hCursor = BuildCopy_Cursor
Case No_Cursor
hCursor = LoadCursor(0, IDC_NO)
End Select
Call SetCursorAPI(hCursor)
Call DestroyIcon(hCursor)
End Property
#If Win64 Then
Private Function CreateAndResizeBitmap( _
ByVal Image As StdPicture, _
ByVal Width As Long, _
ByVal Height As Long _
) As LongLong
Dim lGDIP As LongLong, lBitmap As LongLong, lThumb As LongLong, hBitmap As LongLong
#Else
Private Function CreateAndResizeBitmap( _
ByVal Image As StdPicture, _
ByVal Width As Long, _
ByVal Height As Long _
) As Long
Dim lGDIP As Long, lBitmap As Long, lThumb As Long, hBitmap As Long
#End If
Const S_OK = 0&
Dim CreatheThumbnail As StdPicture
Dim tSI As GdiplusStartupInput
Dim lRes As Long
tSI.GdiplusVersion = 1
lRes = GdiplusStartup(lGDIP, tSI)
If lRes = S_OK Then
lRes = GdipCreateBitmapFromHBITMAP(Image.handle, 0, lBitmap)
If lRes = S_OK Then
lRes = GdipGetImageThumbnail(lBitmap, Width, Height, lThumb, 0, 0)
If lRes = S_OK Then
lRes = GdipCreateHBITMAPFromBitmap(lThumb, hBitmap, 0)
CreateAndResizeBitmap = hBitmap
GdipDisposeImage lThumb
End If
GdipDisposeImage lBitmap
End If
GdiplusShutdown lGDIP
End If
If lRes Then Err.Raise 5, , "Cannot load file."
End Function2- Code Usage example (Standard Module )
VBA Code:
Option Explicit
Sub ShowUserForm()
Dim oCtrl As MSForms.Control
Dim oClass As cls_DraggableControl
Dim oUserForm As Object
Set oUserForm = UserForm1
For Each oCtrl In oUserForm.Controls
If TypeOf oCtrl Is MSForms.Image Then
Set oClass = New cls_DraggableControl
oClass.HookControl ThisClassInstance:=oClass, Ctrl:=oCtrl, UILabel:=oUserForm.Label1
End If
Next
oUserForm.Show
End Sub
