Resize Image inside a Image Control on userform

[Jimmypop]

Hi there

I have the following code to load a image into a userform image control.

Private Sub AddEmpPic_Click()
'to place picture inside imageframe
Image1.PictureSizeMode = fmPictureSizeModeStretch
Call GetImageFile(TextBox5.value)
On Error Resume Next
Image1.Picture = LoadPicture(pathToFile)
End Sub

The code for GetImageFile(TextBox5.Value) is as follows:

Private Function GetImageFile(ByVal Empl As String) As String
With Application.fileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = False
.Filters.Clear
.Filters.Add "JPG", "*.JPG"
.Filters.Add "JPEG File Interchange Format", "*.JPEG"
.Filters.Add "Graphics Interchange Format", "*.GIF"
.Filters.Add "Portable Network Graphics", "*.PNG"
.Filters.Add "Tag Image File Format", "*.TIFF"
.Filters.Add "All Pictures", "*.*"
End With
pathToFile = Application.GetOpenFilename(Title:="Add Employee Image", FileFilter:=UCase(Empl) & " (*.jpg; *.png; *.gif),*.bas;*.png;*.gif")
If pathToFile > "" Then GetImageFile = pathToFile
End Function

It then looks like this with the image rotated (I tried to rotate the image after loading but none of the code I tried worked... This was covered in a previous post Previous attempts)...



So then I realized that it is to do with the image size which is 1800 x 4000... So then I tried to update my code to the one below to resize the image...(When I do images of this size they load correctly onto the image control and to the sheet)

Private Sub AddEmpPic_Click()
'to place picture inside imageframe
Me.Image1.PictureSizeMode = fmPictureSizeModeZoom
Me.Image1.Height = 100
Me.Image1.Width = 100
Call GetImageFile(TextBox5.value)
On Error Resume Next
Image1.Picture = LoadPicture(pathToFile)
End Sub

However, image in Image control is not resizing and now displays as:



Am I on the correct path to do:

Resize image of 1800 x 4000 to 100 x 100 before it is placed inside the Image Control on the userform...

 

[RoryA]

You are resizing the image control, not the image. To resize the image itself will require manipulating the image file directly.

 

[Jimmypop]

I saw that just now while testing...should have checked first... So is there a way to manipuklate the image file directly with vba ...

 

[RoryA]

I wouldn't have a clue.

 

[Jaafar Tribak]

Hi Jimmypop

Resize image of 1800 x 4000 to 100 x 100 before it is placed inside the Image Control on the userform

Using the GDIPlus GdipDrawImageRectRect function can be used to resize the image... The code is wrapped in the ScaleStdPicture function so you simply call it as follows :
Set newStdPicture = ScaleStdPicture(SrcStdPicture, NewWidthInPixels, NewHeightInPixels)

I have adapted this code so that it works in vba

1- In a Standard Module:

Option Explicit

#If Win64 Then
    Private Const NULL_PTR = 0^
#Else
    Private Const NULL_PTR = 0&
#End If

#If VBA7 Then
    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 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 CreateCompatibleDC Lib "gdi32.dll" (ByVal hDC As LongPtr) As LongPtr
    Private Declare PtrSafe Function CreateDIBSection Lib "gdi32.dll" (ByVal hDC As LongPtr, ByRef pBitmapInfo As Any, ByVal un As Long, ByRef lplpVoid As LongPtr, ByVal Handle As LongPtr, ByVal dw As Long) As Long
    Private Declare PtrSafe Function DeleteDC Lib "gdi32.dll" (ByVal hDC As LongPtr) As LongPtr
    Private Declare PtrSafe Function OleCreatePictureIndirect Lib "oleAut32.dll" (PicDesc As Any, RefIID As Any, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
    Private Declare PtrSafe Function SelectObject Lib "gdi32.dll" (ByVal hDC As LongPtr, ByVal hObject As LongPtr) As LongPtr
    Private Declare PtrSafe Function GdiplusStartup Lib "gdiplus" (Token As Long, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As Long
    Private Declare PtrSafe Function GdipDeleteGraphics Lib "GdiPlus.dll" (ByVal mGraphics As LongPtr) As Long
    Private Declare PtrSafe Function GdipCreateFromHDC Lib "gdiplus" (ByVal hDC As LongPtr, hGraphics As LongPtr) As Long
    Private Declare PtrSafe Function GdipDisposeImage Lib "gdiplus" (ByVal Image As LongPtr) As Long
    Private Declare PtrSafe Function GdipCreateBitmapFromHBITMAP Lib "GdiPlus.dll" (ByVal hbm As LongPtr, ByVal hpal As LongPtr, ByRef pbitmap As LongPtr) As Long
    Private Declare PtrSafe Function GdipSetInterpolationMode Lib "GdiPlus.dll" (ByVal hGraphics As LongPtr, ByVal Interpolation As Long) As Long
    Private Declare PtrSafe Function GdipDrawImageRectRect Lib "GdiPlus.dll" (ByVal hGraphics As LongPtr, ByVal hImage As LongPtr, ByVal dstX As Single, ByVal dstY As Single, ByVal dstWidth As Single, ByVal dstHeight As Single, ByVal srcX As Single, ByVal srcY As Single, ByVal srcWidth As Single, ByVal srcHeight As Single, ByVal srcUnit As Long, ByVal imageAttributes As Long, ByVal Callback As LongPtr, ByVal callbackData As LongPtr) As Long
    Private Declare PtrSafe Sub GdiplusShutdown Lib "gdiplus" (ByVal Token As Long)
#Else
    Private Enum LongPtr
        [_]
    End Enum
    Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As LongPtr, ByVal nIndex As Long) As Long
    Private Declare Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hDC As LongPtr) As Long
    Private Declare 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 Function CreateCompatibleDC Lib "gdi32.dll" (ByVal hDC As LongPtr) As LongPtr
    Private Declare Function CreateDIBSection Lib "gdi32.dll" (ByVal hDC As LongPtr, ByRef pBitmapInfo As Any, ByVal un As Long, ByRef lplpVoid As LongPtr, ByVal Handle As LongPtr, ByVal dw As Long) As Long
    Private Declare Function DeleteDC Lib "gdi32.dll" (ByVal hDC As LongPtr) As LongPtr
    Private Declare Function OleCreatePictureIndirect Lib "oleAut32.dll" (PicDesc As Any, RefIID As Any, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
    Private Declare Function SelectObject Lib "gdi32.dll" (ByVal hDC As LongPtr, ByVal hObject As LongPtr) As LongPtr
    Private Declare Function GdiplusStartup Lib "gdiplus" (Token As Long, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As Long
    Private Declare Function GdipDeleteGraphics Lib "GdiPlus.dll" (ByVal mGraphics As LongPtr) As Long
    Private Declare Function GdipCreateFromHDC Lib "gdiplus" (ByVal hDC As LongPtr, hGraphics As LongPtr) As Long
    Private Declare Function GdipDisposeImage Lib "gdiplus" (ByVal Image As LongPtr) As Long
    Private Declare Function GdipCreateBitmapFromHBITMAP Lib "GdiPlus.dll" (ByVal hbm As LongPtr, ByVal hpal As LongPtr, ByRef pbitmap As LongPtr) As Long
    Private Declare Function GdipSetInterpolationMode Lib "GdiPlus.dll" (ByVal hGraphics As LongPtr, ByVal Interpolation As Long) As Long
    Private Declare Function GdipDrawImageRectRect Lib "GdiPlus.dll" (ByVal hGraphics As LongPtr, ByVal hImage As LongPtr, ByVal dstX As Single, ByVal dstY As Single, ByVal dstWidth As Single, ByVal dstHeight As Single, ByVal srcX As Single, ByVal srcY As Single, ByVal srcWidth As Single, ByVal srcHeight As Single, ByVal srcUnit As Long, ByVal imageAttributes As Long, ByVal Callback As LongPtr, ByVal callbackData As LongPtr) As Long
    Private Declare Sub GdiplusShutdown Lib "gdiplus" (ByVal Token As Long)
#End If

    
Private Type GdiplusStartupInput
    GdiplusVersion            As Long
    DebugEventCallback        As LongPtr
    SuppressBackgroundThread  As LongPtr
    SuppressExternalCodecs    As Long
End Type

Private Type uPicDesc
    Size     As Long
    Type     As Long
    hPic     As LongPtr
    hpal     As LongPtr
End Type

Private Type GUID
    Data1           As Long
    Data2           As Integer
    Data3           As Integer
    Data4(0& To 7&) As Byte
End Type


Public Function ScaleStdPicture(thePicture As StdPicture, _
                                NewWidth As Single, NewHeight As Single) As StdPicture
    
    ' Pass dimensions in Pixels only

    Dim GDIsi As GdiplusStartupInput, gToken As Long
    Dim BIH(0 To 9) As Long ' FAUX BitmapInfoHeader structure
    Dim hGraphics As LongPtr, hBitmap As LongPtr
    Dim hDC As LongPtr, hDIB As LongPtr
    
    GDIsi.GdiplusVersion = 1&
    GdiplusStartup gToken, GDIsi            ' initialize GDI+
    If gToken = 0 Then Exit Function
    
    BIH(0) = 40
    BIH(1) = NewWidth: BIH(2) = NewHeight
    BIH(3) = &H180001    ' planes & 24 bit
    hDC = CreateCompatibleDC(NULL_PTR)        ' create buffer
    hDIB = SelectObject(hDC, CreateDIBSection(hDC, BIH(0), 0&, ByVal 0&, 0&, 0&))
    If hDIB = NULL_PTR Then
        GdiplusShutdown gToken              ' failed to create DIB section
        DeleteDC hDC                                ' clean up
        Exit Function
    Else
        Call GdipCreateFromHDC(hDC, hGraphics) ' get graphics context
        If hGraphics Then                       ' set stretch quality & copy stdPicture bitmap/jpg
            GdipSetInterpolationMode hGraphics, 7&
            Call GdipCreateBitmapFromHBITMAP(thePicture.Handle, 0&, hBitmap)
            If hBitmap Then                     ' render to the buffer
                Dim lDPI As Long
                lDPI = pvGetDPI()
                Dim cx As Single, cy As Single
                cx = thePicture.Width * lDPI / 2540!
                cy = thePicture.height * lDPI / 2540!
                GdipDrawImageRectRect hGraphics, hBitmap, 0, 0, NewWidth, NewHeight, 0, 0, _
                                      cx, cy, 2, 0, NULL_PTR, NULL_PTR
                GdipDisposeImage hBitmap        ' clean up
            End If
            GdipDeleteGraphics hGraphics        ' clean up
        End If
    End If
    GdiplusShutdown gToken                      ' clean up
    hDIB = SelectObject(hDC, hDIB)        ' remove our DIB section
    DeleteDC hDC                                ' clean up & create stdPicture from DIB section
    
    Set ScaleStdPicture = pvHandleToStdPicture(hDIB)
    
End Function

Private Function pvHandleToStdPicture(ByVal DIB_HANDLE As LongPtr) As IPicture

    Const IMAGE_BITMAP = 0&: Const PICTYPE_BITMAP = 1&: Const LR_COPYRETURNORG = &H4
    Dim hPtr As LongPtr, IID_IDispatch As GUID, uPicinfo As uPicDesc

    hPtr = CopyImage(DIB_HANDLE, IMAGE_BITMAP, 0&, 0&, LR_COPYRETURNORG)
    With IID_IDispatch
        .Data1 = &H20400
        .Data4(0) = &HC0
        .Data4(7) = &H46
    End With
    With uPicinfo
        .Size = LenB(uPicinfo)
        .Type = PICTYPE_BITMAP
        .hPic = hPtr
        .hpal = NULL_PTR
    End With
   Call OleCreatePictureIndirect(uPicinfo, IID_IDispatch, True, pvHandleToStdPicture)
  
End Function

Private Function pvGetDPI() As Long
    ' DPI relative to virtualization. If this project is not DPI-aware, then the DPI will always be 96
    Dim dDC As LongPtr
    Const LOGPIXELSX As Long = 88
    dDC = GetDC(0)
    pvGetDPI = GetDeviceCaps(dDC, LOGPIXELSX)
    ReleaseDC 0, dDC
End Function

2- Code Usage in the Userform Module:

Option Explicit

Private Sub AddEmpPic_Click()
    Dim pathToFile As String
    Image1.PictureSizeMode = fmPictureSizeModeStretch
    pathToFile = GetImageFile
    If Len(pathToFile) Then
        Set Image1.Picture = ScaleStdPicture(LoadPicture(pathToFile), 100, 100)
    End If
End Sub

Private Function GetImageFile() As String

    Dim pathToFile As String

    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = False
        .Filters.Clear
        .Filters.Add "JPG", "*.JPG"
        .Filters.Add "JPEG File Interchange Format", "*.JPEG"
        .Filters.Add "Graphics Interchange Format", "*.GIF"
        .Filters.Add "Portable Network Graphics", "*.PNG"
        .Filters.Add "Tag Image File Format", "*.TIFF"
        .Filters.Add "All Pictures", "*.*"
    End With
    
    pathToFile = Application.GetOpenFilename(Title:="Add Employee Image", _
    FileFilter:=UCase("Image Files") & " (*.jpg; *.png; *.gif),*.bas;*.png;*.gif")
    If pathToFile <> "False" Then GetImageFile = pathToFile
    
End Function

 

[Dan_W]

Jaafar's approach above is quicker, but I just thought I'd take the opportunity to talk about WIA (again!).

The WIA COM object can scale images, rotate them, and save them as different image formats. The following class module does those three things - note that this is a very basic example, and doesn't include full error handling, etc. Basically, you need to load a picture by setting the the class Source property to the filename. You can use RotateImage routine to rotate the image to either 0, 90, 180, or 270 degrees. You can ScaleImage to 100x100 (as per your instructions above) - there is a further MaintainAspect parameter (defaults to True) which maintains the aspect ratio of the original image, but you can set it to False if you really, really, really want to change the image to 100x100. The demo routine below has invokes the SaveImage routine with a file format parameter set to PNG file format.

In a Userform, with four command buttons (btnLoadPic, btnRotate90, btnScale, btnSave) and one imagebox (Image1):

Option Explicit

Private WIAExample As New clsWIA

Private Sub btnLoadPic_Click()
    Dim Filename As Variant
    Filename = Application.GetOpenFilename(Title:="Add Employee Image")
    If Filename = False Then Exit Sub
    WIAExample.Source = Filename
    Me.Image1.Picture = WIAExample.Picture
End Sub

Private Sub btnRotate90_Click()
    WIAExample.RotateImage RotationEnum.Rotation90
    Me.Image1.Picture = WIAExample.Picture
End Sub

Private Sub btnSave_Click()
    WIAExample.SaveImage PNG
End Sub

Private Sub btnScale_Click()
    WIAExample.ScaleImage 100, 100
    Me.Image1.Picture = WIAExample.Picture
End Sub

and then place the following in a class module - clsWIA.

Option Explicit

Public Enum RotationEnum
    Rotation0 = 0
    Rotation90 = 90
    Rotation180 = 180
    Rotation270 = 270
End Enum

Public Enum ImageFormatEnum
    BMP
    PNG
    GIF
    JPG
    TIFF
End Enum

Private TargetImageFile As Object
Private TargetImageProcess As Object
Private cSource As String
Private cDestination As String

Public Property Let Source(ByVal uSource As String)
    If uSource = vbNullString Then Exit Property
    If Len(Dir(uSource)) Then
        cSource = uSource
        Set TargetImageFile = CreateObject("WIA.ImageFile")
        TargetImageFile.LoadFile uSource
    End If
End Property

Public Property Get Source() As String:                         Source = cSource:               End Property
Public Property Let Destination(ByVal uDestination As String):  cDestination = uDestination:    End Property
Public Property Get Destination() As String:                    Destination = cDestination:     End Property

Public Property Get Picture() As stdole.StdPicture
    Set Picture = TargetImageFile.FileData.Picture
End Property

Public Sub ScaleImage(ByVal NewWidth As Long, ByVal NewHeight As Long, Optional ByVal MaintainAspect As Boolean = True)
    If NewWidth > 0 And NewHeight > 0 Then
        With CreateObject("WIA.ImageProcess")
            .Filters.Add .FilterInfos("Scale").FilterID
            .Filters(1).Properties("MaximumHeight").Value = NewHeight
            .Filters(1).Properties("MaximumWidth").Value = NewWidth
            .Filters(1).Properties("PreserveAspectRatio") = MaintainAspect
            Set TargetImageFile = .Apply(TargetImageFile)
        End With
    End If
End Sub

Public Sub RotateImage(Optional ByVal DegreesRotate As RotationEnum)
    With CreateObject("WIA.ImageProcess")
        .Filters.Add .FilterInfos("RotateFlip").FilterID
        .Filters(1).Properties("RotationAngle") = DegreesRotate
        Set TargetImageFile = .Apply(TargetImageFile)
    End With
End Sub

Public Sub SaveImage(Optional ByVal ImageFileType As ImageFormatEnum)
    Dim FormatFiltersArray As Variant
    Dim FormatFilter As String
    Dim Extension As String
  
    FormatFiltersArray = Array("AB", "AF", "B0", "AE", "B1")
    FormatFilter = "{B96B3C" & FormatFiltersArray(ImageFileType) & "-0728-11D3-9D7B-0000F81EF32E}"
  
    If cDestination = vbNullString Then
        Extension = Choose(ImageFileType + 1, "BMP", "PNG", "GIF", "JPG", "TIFF")
        cDestination = Replace(cSource, TargetImageFile.FileExtension, Extension, , , vbTextCompare)
    End If
  
    With CreateObject("WIA.ImageProcess")
        .Filters.Add .FilterInfos("Convert").FilterID
        .Filters(1).Properties("FormatID").Value = FormatFilter
        .Filters(1).Properties("Quality").Value = 100
        Set TargetImageFile = .Apply(TargetImageFile)
    End With
  
    If Len(Dir(cDestination)) Then Kill cDestination
    TargetImageFile.SaveFile cDestination
End Sub

Private Sub Class_Terminate()
    Set TargetImageFile = Nothing
End Sub

Because this is a COM object, it will likely be a fair bit slower than Jaafar's solution above, but I just thought I'd add my 2 cents. Let me know if you have any difficulty with the above!

 

[Jaafar Tribak]

@Dan_W

Nice and thanks for posting this useful class. The WIA wrapper makes things a lot easier.
I am sure this will come handy.

 

[Jimmypop]

Hi all

Thanks for the suggestions... Will try when I am done travelling for work purposes...

 

[BurqanKpln]

Hi all,
I was the one created this topic but forgot the tell you my special thanks! Now my I can show load my tif files on my userform. I am importing my Xray images to the form. Some of them are really dark and hard to differentiate the ones with the pixel failures. Do we have a chance to tune brightness and contrast of the images with i.e. spin button? THANKS A LOT FOR EVERYONE