Resize userform to fit image

[YasserKhalil]

Hello everyone
In that link
http://vbnet.mvps.org/index.html?code/f ... zeform.htm
I tried to apply to VBA and here's my try
In UserForm1 module (commadbutton and commondialog)

Private Sub UserForm_Initialize()

   CommandButton1.Caption = "Load Image..."

End Sub


Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)

   Unload UserForm2

End Sub


Private Sub CommandButton1_Click()

   With CommonDialog1

      .Filter = "Image Files (gif, jpg, bmp, png)|*.gif;*.jpg;*.bmp;*.png|"
      .FilterIndex = 0
      .InitDir = "C:\"  'change as required
      .ShowOpen
      
      If Len(.filename) > 0 Then
      
         Load UserForm2
         UserForm2.Image1.Picture = LoadPicture(.filename)
         UserForm2.Caption = .filename
         UserForm2.Show

      End If

   End With

End Sub

And In UserForm2, image control inserted

Private Declare Function GetSystemMetrics Lib "user32" _
   (ByVal nIndex As Long) As Long

Private Declare Function GetMenu Lib "user32" _
   (ByVal hwnd As Long) As Long

Private Const SM_CYCAPTION = 4
Private Const SM_CYMENU = 15
Private Const SM_CXFRAME = 32
Private Const SM_CYFRAME = 33

Private twipsx As Long
Private twipsy As Long

 
Private Sub Image1_BeforeDragOver(ByVal Cancel As MSForms.ReturnBoolean, ByVal Data As MSForms.DataObject, ByVal X As Single, ByVal Y As Single, ByVal DragState As MSForms.fmDragState, ByVal Effect As MSForms.ReturnEffect, ByVal Shift As Integer)

End Sub


Private Sub UserForm_Initialize()
'Dim screen
'   twipsx = screen.TwipsPerPixelX
'   twipsy = screen.TwipsPerPixelY
  
   With Image1
      .AutoSize = True
      '.Appearance = 0
      '.Appearance = 0
      .BackColor = &HFFFF80
      .BorderStyle = 0
   End With
   Call AutoSizeToPicture(Image1)
End Sub


'Private Sub Image1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
'
'   Image1.AutoSize = True
'   Call AutoSizeToPicture(Image1)
'
'End Sub

''As PictureBox
Private Sub AutoSizeToPicture(pbox)

   Dim vOffset As Long
   Dim hOffset As Long
                    
   hOffset = (GetSystemMetrics(SM_CXFRAME) * 2) * twipsx
   vOffset = (GetSystemMetrics(SM_CYCAPTION) + (GetSystemMetrics(SM_CXFRAME)) * 2) * twipsx
                        
  'if the form also has a menu,
  'account for that too.
  '
  'NOTE: If you are just hiding the menu, then
  'GetMenu(Me.hwnd) will return non-zero even
  'if the menu is hidden, causing an incorrect
  'vertical offset to be used.  Either delete
  'the menu using the menu editor, or if you
  'must have the ability to show/hide a menu
  'on the picture form, you will need to code
  'to also test for me.mnuX.visible then...
  '
  'You can determine whether the correct sizing
  'is taking place by viewing the values returned
  'to the immediate window from the debug.print
  'code below; the values for the form and
  'picture should be the same, e.g.
  ' picture        3450          2385
  ' form           3450          2385

   If GetMenu(Application.hwnd) <> 0 Then
      vOffset = vOffset + (GetSystemMetrics(SM_CYMENU) * twipsy)
   End If

  'position the picture box and resize the form
   With pbox
      .Left = 0
      .Top = 0
      
      Me.Width = .Width + hOffset
      Me.Height = .Height + vOffset
   End With
  
  'these values should be the same
  'if the calculations worked
   Debug.Print "Image", Image1.Width, Image1.Height
   Debug.Print "Form", UserForm2.Width, UserForm2.Height

End Sub

There are no errors but the code doesn't work as expected. How can I resize the userform to fit the image?
Posted here too

Resize userform to fit image - Eileen's Lounge

 

[YasserKhalil]

@Jaafar Tribak Any help in this topic.

 

[Jaafar Tribak]

@Jaafar Tribak Any help in this topic.

Hi YasserKhalil,

Why don't you manually resize the userform to fit the image control at design time ? if you do that, you won't need to resize the userform with code.

Anyway, if you still want to use a similar code to the (vb6 code) you posted which works for vba then give the following a try :


1- UserForm1:

Option Explicit

#If VBA7 Then
    Private Declare PtrSafe Function SHGetSpecialFolderLocation Lib "shell32.dll" (ByVal hwndOwner As LongPtr, ByVal nFolder As Long, ByRef pIDL As LongPtr) As Long
    Private Declare PtrSafe Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pIDL As LongPtr, ByVal pszPath As String) As Long
    Private Declare PtrSafe Sub CoTaskMemFree Lib "ole32.dll" (pv As Any)
#Else
    Private Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" (ByVal hwndOwner As Long, ByVal nFolder As Long, ByRef pIdl As Long) As Long
    Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pIdl As Long, ByVal pszPath As String) As Long
    Private Declare Sub CoTaskMemFree Lib "ole32.dll" (pv As Any)
#End If


Private Sub UserForm_Initialize()
   CommandButton1.Caption = "Load Image..."
End Sub


Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
   Unload UserForm2
End Sub


Private Sub CommandButton1_Click()

    Const CSIDL_MYPICTURES = &H27

    Dim Dlg As Object
    
    Set Dlg = Application.FileDialog(msoFileDialogFilePicker)
    With Dlg
        .Title = "Select An Image File ..."
        .InitialFileName = GetSpecialFolder(CSIDL_MYPICTURES)
        .AllowMultiSelect = False
        .Filters.Add "Image Files", "*.gif; *.jpg; *.bmp; *.png", 1
        If .Show = -1 Then
            If Len(Dlg.SelectedItems(1)) Then
                Load UserForm2
                UserForm2.Image1.Picture = LoadPicture(Dlg.SelectedItems(1))
                UserForm2.Caption = Dlg.SelectedItems(1)
                UserForm2.Show
            End If
        End If
    End With

End Sub

Private Function GetSpecialFolder(ByVal CSIDL As Long) As String

    Const S_OK = 0&
    Const MAX_PATH = 260
    
    #If VBA7 Then
        Dim pIDL As LongPtr
    #Else
        Dim pIDL As Long
    #End If
    
    Dim sPath As String
    
    If SHGetSpecialFolderLocation(0, CSIDL, pIDL) = S_OK Then
        sPath = Space$(MAX_PATH)
        If SHGetPathFromIDList(pIDL, sPath) Then
            GetSpecialFolder = Left$(sPath, InStr(sPath, Chr$(0)) - 1) & "\"
        End If
        CoTaskMemFree ByVal pIDL
    End If

End Function

2- UserForm2:

Option Explicit

#If VBA7 Then
    Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
#Else
    Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
#End If


Private Sub UserForm_Initialize()

    Const SM_CYCAPTION = 4
    Const SM_CXBORDER = 5
    Const SM_CYBORDER = 6
    Const SM_CXDLGFRAME = 7
    Const SM_CXSIZEFRAME = 45
    Const SM_CYSIZEFRAME = 46

    Dim lHOffset As Long, lVOffset As Long

    lHOffset = 2 * (GetSystemMetrics(SM_CXSIZEFRAME) + GetSystemMetrics(SM_CXDLGFRAME) + _
    GetSystemMetrics(SM_CXBORDER))

    lVOffset = GetSystemMetrics(SM_CYCAPTION) + 2 * (GetSystemMetrics(SM_CYSIZEFRAME) + _
    GetSystemMetrics(SM_CYBORDER))

    With Image1
        .PictureSizeMode = fmPictureSizeModeStretch
        .Left = 0
        .Top = 0
        Me.Width = .Width + lHOffset
        Me.Height = .Height + lVOffset
    End With

End Sub

 

[YasserKhalil]

Amazing my friend. Thank you very much.