Option Explicit
Private resizeEnabled As Boolean
Private mouseX As Double
Private mouseY As Double
Private minWidth As Double
Private minHeight As Double
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
#If VBA7 Then
Private Declare PtrSafe Function GetClientRect Lib "user32.dll" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare PtrSafe Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByRef hwnd As Long) As Long
#Else
Private Declare Function GetClientRect Lib "user32.dll" (ByVal hwnd As Long, lpRect As Any) As Long
Private Declare Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByRef hwnd As Long) As Long
#End If
Private Sub UserForm_Initialize()
'Position the resize icon
lblResizer.Left = Me.InsideWidth - lblResizer.Width
lblResizer.Top = Me.InsideHeight - lblResizer.Height
minHeight = 125
minWidth = 125
'High quality image in form
Call put_image_in_form
'FillFormWithImage Form:=Me, imageFilePathName:="C:\test\figure1.PNG" '<== change PathName + extension to suit.
End Sub
Sub put_image_in_form()
FillFormWithImage Form:=Me, imageFilePathName:="C:\test\figure1.PNG" '<== change PathName + extension to suit.
End Sub
Private Sub lblResizer_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
'The user clicked on the lblResizer
resizeEnabled = True
'Capture the mouse position on click
mouseX = X
mouseY = Y
End Sub
Private Sub lblResizer_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
'Check if the UserForm is not resized too small
Dim allowResize As Boolean
allowResize = True
If Me.Width + X - mouseX < minWidth Then allowResize = False
If Me.Height + Y - mouseY < minHeight Then allowResize = False
'Check if the mouse clicked on the lblResizer
If resizeEnabled = True And allowResize = True Then
'Resize/move objects based on mouse movement since click
'Resize the UserForm
Me.Width = Me.Width + X - mouseX
Me.Height = Me.Height + Y - mouseY
'Resize controls
Call put_image_in_form
'Move the Close Button
cmdClose.Left = cmdClose.Left + X - mouseX
cmdClose.Top = cmdClose.Top + Y - mouseY
'Move the Resizer icon
lblResizer.Left = Me.InsideWidth - lblResizer.Width
lblResizer.Top = Me.InsideHeight - lblResizer.Height
End If
End Sub
Private Sub lblResizer_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
'The user un-clicked on the lblResizer
resizeEnabled = False
End Sub
Private Sub cmdClose_Click()
Unload Me
End Sub
Private Sub FillFormWithImage(ByVal Form As UserForm, ByVal imageFilePathName As String)
Dim oWIA As Object, oImg As Object
Dim iWidth As Integer, iHeight As Integer
Dim hwnd As Long, uRect As RECT
Call IUnknown_GetWindow(Form, hwnd)
Call GetClientRect(hwnd, uRect)
With uRect
iWidth = .Right - .Left
iHeight = .Bottom - .Top
End With
Set oWIA = CreateObject("WIA.ImageProcess")
Set oImg = CreateObject("WIA.ImageFile")
oImg.LoadFile imageFilePathName
With oWIA
.Filters.Add .FilterInfos.Item("Scale").FilterID
.Filters(1).Properties("MaximumWidth") = iWidth
.Filters(1).Properties("MaximumHeight") = iHeight
.Filters(1).Properties("PreserveAspectRatio") = False
Set Form.Picture = .Apply(oImg).FileData.Picture
End With
End Sub