VBA – WIA – Resize/Scale an Image

I was trying to help someone out in the MSDN forum, pictures change height width, with wanting to resize images from within an MS Access database. As you can see from my initial post, there are a multitude of possible approaches:

After my initial post just offering a few options, I decided to hand the OP a working solution because I know it isn’t always easy to translate some of our suggestions into concrete solutions, so I created the following Function which employs WIA.  As you can see, it is very simple and straightforward.  As always, to avoid requiring any reference libraries, this function uses Late Binding techniques.

'---------------------------------------------------------------------------------------
' Procedure : WIA_ResizeImage
' Author    : Daniel Pineault, CARDA Consultants Inc.
' Website   : http://www.cardaconsultants.com
' Purpose   : Resize an image based on Max width and Max height using WIA
' Copyright : The following may be altered and reused as you wish so long as the
'             copyright notice is left unchanged (including Author, Website and
'             Copyright).  It may not be sold/resold or reposted on other sites (links
'             back to this site are allowed).
' Req'd Refs: Late Binding  -> None required
'             Early Binding -> Microsoft Windows Image Acquisition Library vX.X
'
' Windows Image Acquisition (WIA)
'   https://msdn.microsoft.com/en-us/library/windows/desktop/ms630368(v=vs.85).aspx
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' sInitialImage : Fully qualified path and filename of the original image to resize
' sResizedImage : Fully qualified path and filename of where to save the resized image
' lMaximumWidth : Maximum allowable image width
' lMaximumHeight: Maximum allowable image height
' bPreserveAspectRatio: Whether the image aspect ratio should be preserved, or not
' bOverwrite    : Whether it should overwrite the output file if it already exists
'
' Usage:
' ~~~~~~
' Call WIA_ResizeImage("C:\Users\Public\Pictures\Sample Pictures\Chrysanthemum.jpg", _
'                      "C:\Users\MyUser\Desktop\Chrysanthemum_small.jpg", _
'                      800, 600)
' Call WIA_ResizeImage("C:\Users\Public\Pictures\Sample Pictures\Chrysanthemum.jpg", _
'                      "C:\Users\MyUser\Desktop\Chrysanthemum_small.jpg", _
'                      800, 600, False)
' Call WIA_ResizeImage("C:\Users\Public\Pictures\Sample Pictures\Chrysanthemum.jpg", _
'                      "C:\Users\MyUser\Desktop\Chrysanthemum_small.jpg", _
'                      800, 600, True, True)
'
' Revision History:
' Rev       Date(yyyy/mm/dd)        Description
' **************************************************************************************
' 1         2017-01-18              Initial Release
' 2         2022-12-15              Added bPreserveAspectRatio argument
'                                   Added bOverwrite argument
'---------------------------------------------------------------------------------------
Public Function WIA_ResizeImage(sInitialImage As String, sResizedImage As String, _
                                lMaximumWidth As Long, lMaximumHeight As Long, _
                                Optional bPreserveAspectRatio As Boolean = True, _
                                Optional bOverwrite As Boolean = False) As Boolean
On Error GoTo Error_Handler
    #Const WIA_EarlyBind = False    'True => Early Binding / False => Late Binding
    #If WIA_EarlyBind = True Then
        Dim oIF               As WIA.ImageFile
        Dim oIP               As WIA.ImageProcess

        Set oIF = New WIA.ImageFile
        Set oIP = New WIA.ImageProcess
    #Else
        Dim oIF               As Object
        Dim oIP               As Object

        Set oIF = CreateObject("WIA.ImageFile")
        Set oIP = CreateObject("WIA.ImageProcess")
    #End If

    If Len(Dir(sResizedImage)) > 0 Then
        If bOverwrite = True Then
            Kill sResizedImage
        Else
            Exit Function
        End If
    End If

    oIP.Filters.Add oIP.FilterInfos("Scale").FilterID
    oIP.Filters(1).Properties("MaximumWidth") = lMaximumWidth
    oIP.Filters(1).Properties("MaximumHeight") = lMaximumHeight
    oIP.Filters(1).Properties("PreserveAspectRatio") = bPreserveAspectRatio

    oIF.LoadFile sInitialImage
    Set oIF = oIP.Apply(oIF)
    oIF.SaveFile sResizedImage
    WIA_ResizeImage = True

Error_Handler_Exit:
    On Error Resume Next
    Set oIP = Nothing
    Set oIF = Nothing
    Exit Function

Error_Handler:
    MsgBox "The following error has occurred" & vbCrLf & vbCrLf & _
           "Error Number: " & Err.Number & vbCrLf & _
           "Error Source: WIA_ResizeImage" & vbCrLf & _
           "Error Description: " & Err.Description & _
           Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
           , vbOKOnly + vbCritical, "An Error has Occurred!"
    Resume Error_Handler_Exit
End Function

The function will return True when the Resize operation is successful and False in all other cases. So you can validate your calls to the function very easily.

Also note that this function can both reduce or blow up an image. It works fine either way, but obviously, blowing up a picture will automatically imply a lost of quality.

Other WIA Image Manipulation Posts

44 responses on “VBA – WIA – Resize/Scale an Image”

  5. Christian Johansen

    Fisrt of all, thanks! This is great and works perfectly!

    I searched (https://msdn.microsoft.com/en-us/library/windows/desktop/ms630506(v=vs.85).aspx) and didn’t find any condition parameter on the WIA.ImageFile savefile method to overwrite the saved image file, as
    I thought others like me would like to implement it on this function, here is what I did (there might be a better/simpler way to do this) :

    1st. Add an optional boolean overwrite parameter like this:
    Public Function WIA_ResizeImage(sInitialImage As String, sResizedImage As String, _
    lMaximumWidth As Long, lMaximumHeight As Long, _
    Optional bOverwrite As Boolean = False) As Boolean

    2nd. Check if file exists and bOverwrite ( I used this post as reference https://stackoverflow.com/questions/67835/deleting-a-file-in-vba), to do so replace the oWIA.SaveFile line with the code below:
    If Dir(sResizedImage) “” And bOverwrite Then
    ‘ First remove readonly attribute, if set
    SetAttr sResizedImage, vbNormal
    ‘ Then delete the file
    Kill sResizedImage
    ‘ Save resized image
    oWIA.SaveFile sResizedImage
    Else
    oWIA.SaveFile sResizedImage
    End If

    1. Daniel Pineault Post author

      Nice addition. My only, very small change, would be to extract the SaveFile from the If statement as it applies in both cases. So I’d do

          If Dir(sResizedImage) <> "" And bOverwrite = True Then
        ' First remove readonly attribute, if set
        SetAttr sResizedImage, vbNormal
        ' Then delete the file
        Kill sResizedImage
    End If
    ' Save resized image
    oWIA.SaveFile sResizedImage
  7. Dennis Fidler

    Thanks, this worked great. We have club pictures stored on our server, but Access reports can’t handle the pictures because of the file size. This solved the problem, I converted them all to 1000×1000 and it worked perfectly.

  8. Morten Lamoey

    Excellent work.

    I trying to resize an image being sent to me in an XML file, using base64 encoding. My program decode and saves the image to disk. Is it possible to take the decoded image before saving to disk, resize it, then save it to disk?

  9. Bob D

    Daniel: This is an awesome function that saved me DAYS of work. The way it is written and commented is superb. I wish that my code looked and worked half as well. I am in the process of converting our old, clunky Student Management database into a SharePoint site. The process of learning SharePoint and converting the DB to it has been grueling to say the least. Today I needed to rename and resized all 4000 photos which I assumed would take a week if I was lucky. Your function made my day! Why spend a week when you can spend an hour? It is a work of art! Thanks again!

  11. Joseph Bugeja

    Hi.

    Many thanks for making this code available. It works very well.

    Only gripe I have is the resized image quality is not great and seems to be at the lower end of quality.

    Can your code be modified to include a quality setting to save the resized images at the highest quality please

    Your convert code has this quality as lquality but I could not get it to work with the resize only code.

    Thank you in advance.

  13. Umer

    Wow this was just superb was doing it in JAVA and than found this, This solved major issues i was having thanks a million From Pakistan

    1. James Martin

      Was desperate to be able to compress images a year ago, as I need to quickly compress multiple images, in docx upload to a Client browser account system, which has a 4MB limit. Nothing online for this, which I was surprised by. Struggled for 6 months with SendKeys. But then had a breakthrough by using CommandBars Execute MSo. The rest was fairly easy to code. The code looks a bit bloated, as I have left in a delay timer which is useful for othe macros when needed. I tried to stop screen flicker, but this just slows the macro down, I’m not sensitive to strobing but some people will be. As this is not directly codeable in the Object Model and ScreenUpdating= False doesn’t work. SendKeys is used once for the compression amount I had to do SendKeys twice as my USB number pad was toggling off or on, if there was an odd number of images compressed. The key thing with this is that, you have to select 1 image so the special ribbon command bar appears. Also worth noting the image loops work if Word was last used to format one image or all images (depends on one tick as last use is remembered). I have created test macros to detect if this tick is on or off, so it is possible to switch off only apply to this picture so the loop and flicker doesn’t happen. If you have hundreds of images, this would save time. I only do up to 20-30 images. I have a copy of this macro on my QAT for 96ppi if needed.

      Sub MacroC_28_06_2022()
      ‘150ppi
      Word.Application.ScreenUpdating = False
      ‘SOURCE: jam61mar@gmail.com
      ‘if no document is open and QAT is pressed in error
      If Word.Application.Documents.Count = 0 Then
      Exit Sub
      End If
      Dim oIlS As inlineshape
      If Word.ActiveDocument.Inlineshapes.Count > 0 Then
      Word.ActiveDocument.Inlineshapes(1).Select
      VBA.SendKeys “%W{ENTER}”, True Application.Commandbars.ExecuteMso (“PicturesCompress”)
      DoEvents ”’28/06/2022 Add SendKeys for a 2nd time each time used to undo toggling off the NumLock
      VBA.SendKeys “%W{ENTER}”, True Application.Commandbars.ExecuteMso (“PicturesCompress”)
      Dim PauseTime, Start, Finish, TotalTime
      PauseTime = 0
      Start = Timer
      Do While Timer 1 Then Word.ActiveDocument.Inlineshapes(i).Select
      VBA.SendKeys “%W{ENTER}”, True Application.Commandbars.ExecuteMso (“PicturesCompress”)
      DoEvents ”’2nd running to toggle numlock back on
      VBA.SendKeys “%W{ENTER}”, True Application.Commandbars.ExecuteMso (“PicturesCompress”)
      Dim PauseTime, Start, Finish, TotalTime
      PauseTime = 0
      Start = Timer
      Do While Timer < Start + PauseTime
      DoEvents
      Loop
      Finish = Timer
      TotalTime = Finish – Start
      Else
      End
      End If
      Next i
      Word.Application.ScreenUpdating = True
      End Sub

      1. Daniel Pineault Post author

        SendKeys are dangerous, so I avoid them at all cost! In over 15 years of development, I believe I only have 1 procedure that uses them. So I get very nervous with a procedure that uses them liberally like this one does. I’d be curious to know if those couldn’t be replaced with proper Word method calls to make the code more robust.

        I have multiple posts on image resizing etc… including https://www.devhut.net/vba-wia-convert-the-image-format/ in which you can set the image format and compression level of the resulting image. I personally try not to rely on an external application (when possible). If I wasn’t happy with using WIA, GDI+, … and was truly requiring to go the route of an external application, I’d probably automate Irfanview as it can do this with a single line and the shell command.

        If I get some time, I may compare Word vs WIA or GDI to compare speed, image quality, …

  14. Martin Froelich

    Hello,

    thank you for sharing.
    I do wonder if I’m the only one having issues with the rotation / orientation of the picture file.
    It seems to me, that the WIA Routine does not care about or messes up with the EXIF Data.

    Example:
    The Original File was taken Upside down.
    All File Explorers or Image Viewers will read the according exif information and display the picture correctly…
    When I resize the picuture using ifranview (for example) – this is still the same…
    When I resize using your routine the resized picture will be displayed upside down…

    any idea?
    Would really be much appreciated..

    KR, Martin

    1. Daniel Pineault Post author

      WIA does not take into account the EXIF orientation information. If you wish to do so you would need to use a dll, … to first read the orientation value, apply it, then apply the standard rotation beyond that point.

      1. Martin Froelich

        Daniel,

        thank you for your reply. In fact I think this is a large downside of this method against any other.
        Here is how I get along with it at the moment.

        Still using your WIA Routine for resizing…as it is very fast
        But after that I’m shelling using ‘imagemagick’s -auto-orientation….

        Does look like this at the moment:
        Public Function WIA_ResizeImage(ByVal sInitialImage As String, ByVal sResizedImage As String, ByVal lMaximumHeight As Long, ByVal lMaximumWidth As Long) As Boolean
        On Error GoTo Error_Handler
        Dim oWIA As Object ‘WIA.ImageFile
        Dim oIP As Object ‘ImageProcess
        Dim scmd As String
        Dim pathImageMagickMogrify As String

        Set oWIA = CreateObject(“WIA.ImageFile”)
        Set oIP = CreateObject(“WIA.ImageProcess”)

        oIP.Filters.Add oIP.FilterInfos(“Scale”).FilterID
        oIP.Filters(1).Properties(“MaximumWidth”) = lMaximumWidth
        oIP.Filters(1).Properties(“MaximumHeight”) = lMaximumHeight

        oWIA.LoadFile sInitialImage
        Set oWIA = oIP.Apply(oWIA)
        oWIA.SaveFile sResizedImage
        WIA_ResizeImage = True

        ‘ Addin- ImageMagick- -auto-orient -using mogrify
        ‘ https://de.wikipedia.org/wiki/ImageMagick#Kommandozeile ‘mogrify does the modification and replaces the file
        ‘ https://imagemagick.org/script/mogrify.php
        ‘—————————————————————————————————————
        pathImageMagickMogrify = getPfad_Element(“ImageMagick_mogrify”) ‘ gives us the complete path to where the mogrify.exe is stored on the drive
        scmd = Chr(34) & pfadImageMagickMogrify & Chr(34) & ” -auto-orient ” & Chr(34) & sResizedImage & Chr(34) ‘creates the according shell string
        Shell scmd, vbHide ‘ runs the command in the cosole
        ‘Addin end
        ‘—————————————————————————————————————

        Error_Handler_Exit:
        On Error Resume Next
        If Not oIP Is Nothing Then Set oIP = Nothing
        If Not oWIA Is Nothing Then Set oWIA = Nothing
        Exit Function

        Error_Handler:
        MsgBox “The following error has occurred” & vbCrLf & vbCrLf & _
        “Error Number: ” & Err.Number & vbCrLf & _
        “Error Source: WIA_ResizeImage” & vbCrLf & _
        “Error Description: ” & Err.Description & _
        Switch(Erl = 0, “”, Erl 0, vbCrLf & “Line No: ” & Erl) _
        , vbOKOnly + vbCritical, “An Error has Occurred!”
        Resume Error_Handler_Exit
        End Function

    2. Daniel Pineault Post author

      You can simply read the orientation exif tag value and apply it, no need for imagemagick.

      oIF.Properties("Orientation").Value

      and then apply the appropriate rotation that corresponds to that value.

      https://exiftool.org/TagNames/EXIF.html
      1 = Horizontal (normal) – Nothing to do
      2 = Mirror horizontal
      3 = Rotate 180
      4 = Mirror vertical
      5 = Mirror horizontal and rotate 270 CW
      6 = Rotate 90 CW
      7 = Mirror horizontal and rotate 90 CW
      8 = Rotate 270 CW

      Don’t forget, it you perform such operations and save the file, then you should also reset the Orientation tag value accordingly prior to saving.

  17. A S Mughal

    Thank you very much for sharing
    just wondering if there is a similar code cropping images and replacing the original ones with cropped ones in ms access forms.
    Thanks

  18. Vincent

    Thanks so much for sharing this great work
    i’m a novice in VBA programing. i wish to know the location where the code can be copied and pasted for it to work.

      1. Vincent

        That is exactly what i did. but when i insert a heavy image, the database size increases drastically.
        i worked with office 7, then with office 16.
        Is there anything to do again in that VBA code?

    2. James Martin

      Hi, I’ve done the same but with a lot less code. Below is the code from a standalone “Macro s” which I’ve pasted out of an Outlook macro, so you can see how it works. Basically I have a wwe.slipstick.com Outlook macro which saves a selected email in list view, to docx. I am manipulating customer pictures all day. Originally High Res pictures would be oversized in the docx. So I created Macro s to force the images to the page margin, I now have it added into the Outlook macro in this form so not fully declared etc to work stand alone.

      Dim oShape As InlineShape
      For Each oShape In wrdDoc.InlineShapes
      If oShape.Width > 510 Then
      oShape.LockAspectRatio = True
      oShape.Width = 510
      End If

      If oShape.Height > 660 Then
      oShape.LockAspectRatio = True
      oShape.Height = 660
      End If

      I have an inverse of this Macro S to maximise to page margins, as after manipulating/moving images in the docx often they shrink. Overlong mobile images can trip this up, but you just have to tailor this to your needs.

      1. Daniel Pineault Post author

        A lot less code? It’s 1 line shorter, doesn’t have error handling and it’s incomplete as it doesn’t save the resulting resized image/shape. Moreover, it also relies on Word, so you need to ensure your users have Word installed.

        I looked at this many moons ago, but IMHO wasn’t the way to go. I also like WIA as it opens the door to doing many other image manipulations.

        As they say, to each their own. If it works for you great, that’s all that truly matter at the end of the day.

  19. Vincent

    The other issue is that , the new MaximumWidth and MaximumHeight values are not specified in the code. i don’t know if i have to specify them or just consider the given code as it is.

    1. Daniel Pineault Post author

      I’m afraid I do not understand.

      Both lMaximumWidth and lMaximumHeight are input variables of the function and later used to define the filter which is applied to the image to resize it.

  21. RaRa

    Hi Daniel,

    is there also a possibility to reduce the Pixel Depth e.g. down from 32 to 16 or 8? (Img.PixelDepth).

    Thanks Ralf

    1. Daniel Pineault Post author

      I do not believe so. We can read the value, but it doesn’t seem to be exposed via any of the ImageProcess FilterInfos properties to actually change/set it.

  23. Jim

    Hi Daniel,

    I’m loving all your routines for image manipulation using WIA in VBA. They are working great! I’m wondering if it’s possible to add text on top of an image with WIA?

    Thanks!
    Jim

  24. Kevin

    Hello, thanks for all the help you offer.
    I have been using the function for some years to create thumbnail images from PDF’s.
    The one problem I have been having is for some of the PDF’s (almost all scans of engineering drawings) the image is distorted.
    The image field in my Form is 3.2xx” x 3.9xx” so I tried changing this
    Call WIA_ResizeImage(strSourceFolder & strFileName, _
    strResizedFolder & strFileName, _
    320, 247)
    to
    Call WIA_ResizeImage(strSourceFolder & strFileName, _
    strResizedFolder & strFileName, _
    320, 390)
    One file worked, a group did not (including the image that did work the first time, it is now distorted again), so I changed the 390 to 999, same result.
    I see that you have added ‘bPreserveAspectRatio’ to the code.
    When replacing my code with your new complete code it errored (I will figure out the issue and use your new version) so I just added these
    Optional bPreserveAspectRatio As Boolean = True) As Boolean
    and
    oIP.Filters(1).Properties(“PreserveAspectRatio”) = bPreserveAspectRatio
    It functions but is not affecting the distortion.
    Is bPreserveAspectRatio meant to keep the original ratio no matter the max height or width?