Re-Save and compress images from a folder

kelly mort

kelly mort

Well-known Member
Joined
Apr 10, 2017
Messages
2,169
Office Version
  1. 2016
Platform
  1. Windows
Hello,
So I have been trying to find a solution to my image compression issue for a while now and I came across this code in vb. Net

I have no idea how to understand it. But I have the feeling it's closer to my need.

I have a folder which contains these images of various sizes that I want to reduce their sizes. As low as 30kb to 50kb is okay. I am not interested in the quality here if that will be an obstacle.

So that when I run the code, then we look into that folder and locate all images above the 50kb then re-save them to that 50kb.

Yeah that's what I can think of now.

If there is a better way to achieve this please highlight that for me.

Doing it manually will not be an option here since there may be few images involved. Say 700:LOL:;):ROFLMAO::ROFLMAO:

Code: 
Code 1 - a given sample
Code: 
[COLOR=#0000FF]Private[/COLOR] [COLOR=#0000FF]Class[/COLOR] JpegTools
     [COLOR=#0000FF]Private[/COLOR] codecs [COLOR=#0000FF]As[/COLOR] ImageCodecInfo() = ImageCodecInfo.GetImageEncoders()
     [COLOR=#0000FF]Private[/COLOR] quality [COLOR=#0000FF]As[/COLOR] [COLOR=#0000FF]Long[/COLOR]

     [COLOR=#0000FF]Public[/COLOR] ici [COLOR=#0000FF]As[/COLOR] ImageCodecInfo = [COLOR=#0000FF]Nothing[/COLOR]
     [COLOR=#0000FF]Public[/COLOR] ep [COLOR=#0000FF]As[/COLOR] [COLOR=#0000FF]New[/COLOR] EncoderParameters()
     [COLOR=#0000FF]Public[/COLOR] compressionRatio [COLOR=#0000FF]As[/COLOR] [COLOR=#0000FF]Long[/COLOR]

     [COLOR=#0000FF]Public[/COLOR] [COLOR=#0000FF]Sub[/COLOR] [COLOR=#0000FF]new[/COLOR]([COLOR=#0000FF]ByVal[/COLOR] _compressionRatio [COLOR=#0000FF]As[/COLOR] [COLOR=#0000FF]Long[/COLOR], [COLOR=#0000FF]Optional[/COLOR] [COLOR=#0000FF]ByRef[/COLOR] errMsg [COLOR=#0000FF]As[/COLOR] [COLOR=#0000FF]String[/COLOR] = [COLOR=#800080]"[/COLOR][COLOR=#800080]"[/COLOR])

         compressionRatio    = _compressionRatio
         [COLOR=#0000FF]If[/COLOR] compressionRatio < [COLOR=#000080]0[/COLOR] [COLOR=#0000FF]then[/COLOR] compressionRatio = [COLOR=#000080]0[/COLOR]
         [COLOR=#0000FF]If[/COLOR] compressionRatio > [COLOR=#000080]100[/COLOR] [COLOR=#0000FF]then[/COLOR] compressionRatio = [COLOR=#000080]100[/COLOR]
         quality             = ([COLOR=#000080]100[/COLOR] - compressionRatio)

         [COLOR=#0000FF]Try[/COLOR]
             [COLOR=#0000FF]For[/COLOR] [COLOR=#0000FF]Each[/COLOR] codec [COLOR=#0000FF]As[/COLOR] ImageCodecInfo [COLOR=#0000FF]In[/COLOR] codecs
                 [COLOR=#0000FF]If[/COLOR] codec.MimeType = [COLOR=#800080]"[/COLOR][COLOR=#800080]image/jpeg"[/COLOR] [COLOR=#0000FF]Then[/COLOR]
                     ici = codec
                 [COLOR=#0000FF]End[/COLOR] [COLOR=#0000FF]If[/COLOR]
             [COLOR=#0000FF]Next[/COLOR]

             ep.Param([COLOR=#000080]0[/COLOR]) = [COLOR=#0000FF]New[/COLOR] EncoderParameter(System.Drawing.Imaging.Encoder.Quality, quality)
         [COLOR=#0000FF]Catch[/COLOR] ex [COLOR=#0000FF]As[/COLOR] Exception
             errMsg = ex.Message
         [COLOR=#0000FF]End[/COLOR] [COLOR=#0000FF]Try[/COLOR]
     [COLOR=#0000FF]End[/COLOR] [COLOR=#0000FF]Sub[/COLOR]
 [COLOR=#0000FF]End[/COLOR] [COLOR=#0000FF]Class[/COLOR]

 [COLOR=#0000FF]Private[/COLOR] JpgTools [COLOR=#0000FF]As[/COLOR] JpegTools

 [COLOR=#008000][I]'[/I][/COLOR][COLOR=#008000][I] Save an Image() to a jpeg file and specify the compression % (Valid values for compressionRatio are 0 - 100)[/I][/COLOR]
 [COLOR=#0000FF]Public[/COLOR] [COLOR=#0000FF]Function[/COLOR] SaveImgToFile([COLOR=#0000FF]ByRef[/COLOR] img [COLOR=#0000FF]As[/COLOR] Image, [COLOR=#0000FF]ByVal[/COLOR] fullPathWithFileName [COLOR=#0000FF]As[/COLOR] [COLOR=#0000FF]String[/COLOR], [COLOR=#0000FF]ByVal[/COLOR] compressionRatio [COLOR=#0000FF]As[/COLOR] [COLOR=#0000FF]Long[/COLOR], _
                               [COLOR=#0000FF]Optional[/COLOR] [COLOR=#0000FF]ByRef[/COLOR] errMsg [COLOR=#0000FF]As[/COLOR] [COLOR=#0000FF]String[/COLOR] = [COLOR=#800080]"[/COLOR][COLOR=#800080]"[/COLOR]) [COLOR=#0000FF]As[/COLOR] [COLOR=#0000FF]Boolean[/COLOR]

     [COLOR=#0000FF]If[/COLOR] JpgTools [COLOR=#0000FF]Is[/COLOR] [COLOR=#0000FF]Nothing[/COLOR] [COLOR=#0000FF]Then[/COLOR] JpgTools = [COLOR=#0000FF]New[/COLOR] JpegTools(compressionRatio, errMsg)
     [COLOR=#0000FF]If[/COLOR] JpgTools.compressionRatio <> compressionRatio [COLOR=#0000FF]then[/COLOR] JpgTools = [COLOR=#0000FF]New[/COLOR] JpegTools(compressionRatio, errMsg)
     [COLOR=#0000FF]If[/COLOR] errMsg <> [COLOR=#800080]"[/COLOR][COLOR=#800080]"[/COLOR] [COLOR=#0000FF]then[/COLOR] [COLOR=#0000FF]Return[/COLOR] [COLOR=#0000FF]False[/COLOR]

     [COLOR=#0000FF]Try[/COLOR]
         img.Save(fullPathWithFileName, JpgTools.ici, JpgTools.ep)
     [COLOR=#0000FF]Catch[/COLOR] ex [COLOR=#0000FF]As[/COLOR] Exception
         errMsg = ex.Message
         [COLOR=#0000FF]Return[/COLOR] [COLOR=#0000FF]False[/COLOR]
     [COLOR=#0000FF]End[/COLOR] [COLOR=#0000FF]Try[/COLOR]

     [COLOR=#0000FF]Return[/COLOR] [COLOR=#0000FF]True[/COLOR]
 [COLOR=#0000FF]End[/COLOR] [COLOR=#0000FF]Function
[/COLOR]

Code: 
Code 2 - a given sample
Code: 
[COLOR=#666666][FONT='inherit']Int64 RequiredLength = (Int64) (3.8 * 1024);[/FONT][/COLOR]

[COLOR=#666666][FONT='inherit']//EncoderParameter epQuality = new EncoderParameter(System.Drawing.Imaging.Encoder.Quality, (int)numQual.Value);[/FONT][/COLOR]
[COLOR=#666666][FONT='inherit']int val = 50;[/FONT][/COLOR]
[COLOR=#666666][FONT='inherit']EncoderParameter epQuality = null;[/FONT][/COLOR]
[COLOR=#666666][FONT='inherit']//epQuality = new EncoderParameter(System.Drawing.Imaging.Encoder.Quality, val);[/FONT][/COLOR]
[COLOR=#666666][FONT='inherit']epQuality = new EncoderParameter(System.Drawing.Imaging.Encoder.Quality, val);[/FONT][/COLOR]

[COLOR=#666666][FONT='inherit']// Store the quality parameter in the list of encoder parameters[/FONT][/COLOR]
[COLOR=#666666][FONT='inherit']EncoderParameters epParameters = new EncoderParameters(1);[/FONT][/COLOR]
[COLOR=#666666][FONT='inherit']epParameters.Param[0] = epQuality;[/FONT][/COLOR]

[COLOR=#666666][FONT='inherit']// Create a new Image object from the current file[/FONT][/COLOR]
[COLOR=#666666][FONT='inherit']Image newImage = null;[/FONT][/COLOR]
[COLOR=#666666][FONT='inherit']newImage = Image.FromFile(strFile);[/FONT][/COLOR]
[COLOR=#666666][FONT='inherit']// Get the file information again, this time we want to find out the extension[/FONT][/COLOR]
[COLOR=#666666][FONT='inherit']FileInfo fiPicture = new FileInfo(strFile);[/FONT][/COLOR]
[COLOR=#666666][FONT='inherit']// Save the new file at the selected path with the specified encoder parameters, and reuse the same file name[/FONT][/COLOR]
[COLOR=#666666][FONT='inherit']string savepath = "TempResize\\" + fiPicture.Name;[/FONT][/COLOR]
[COLOR=#666666][FONT='inherit']newImage.Save(savepath, iciJpegCodec, epParameters);[/FONT][/COLOR]
[COLOR=#666666][FONT='inherit']FileInfo ResizedInfo = new FileInfo(savepath);[/FONT][/COLOR]
[COLOR=#666666][FONT='inherit']Int64 ResizedInBytes = ResizedInfo.Length;[/FONT][/COLOR]
[COLOR=#666666][FONT='inherit']//double somrthing = (3.8 * val) / ResizedInKb;[/FONT][/COLOR]
[COLOR=#666666][FONT='inherit']Int64 RequiredVal = (RequiredLength * val) / ResizedInBytes;[/FONT][/COLOR]
[COLOR=#666666][FONT='inherit']epQuality = new EncoderParameter(System.Drawing.Imaging.Encoder.Quality, RequiredVal);[/FONT][/COLOR]
[COLOR=#666666][FONT='inherit']// Create a new Image object from the current file[/FONT][/COLOR]
[COLOR=#666666][FONT='inherit']Image ResizedImage = null;[/FONT][/COLOR]
[COLOR=#666666][FONT='inherit']ResizedImage = Image.FromFile(strFile);[/FONT][/COLOR]
[COLOR=#666666][FONT='inherit']epParameters.Param[0] = epQuality;[/FONT][/COLOR]
[COLOR=#666666][FONT='inherit']ResizedImage.Save("TempResize\\New\\" + fiPicture.Name, iciJpegCodec, epParameters);
[/FONT][/COLOR]
 
Last edited:
Sort by date Sort by votes
Ok- Please ignore the previous main API code and use this one instead :

1- In a Standard Module:
Code: 
Option Explicit

Private Enum PictureTypeConstants
      vbPicTypeNone = 0
      vbPicTypeBitmap = 1
      vbPicTypeMetafile = 2
      vbPicTypeIcon = 3
      vbPicTypeEMetafile = 4
End Enum
   
Private Type BITMAP
    bmType As Long
    bmWidth As Long
    bmHeight As Long
    bmWidthBytes As Long
    bmPlanes As Integer
    bmBitsPixel As Integer
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
        bmBits As LongPtr
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
        bmBits As Long
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If
End Type
   
Private Type uPicDesc
    Size As Long
    Type As Long
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
        hPic As LongPtr
        hPal As LongPtr
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
       hPic As Long
       hPal As Long
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  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 GdiplusStartupInput
   GdiplusVersion As Long
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
        DebugEventCallback As LongPtr
        SuppressBackgroundThread As LongPtr
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
        DebugEventCallback As Long
        SuppressBackgroundThread As Long
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If
   SuppressExternalCodecs As Long
End Type

[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then

    Private Declare PtrSafe Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As LongPtr
    Private Declare PtrSafe Function FreeLibrary Lib "kernel32" (ByVal hLibModule As LongPtr) As Long
    Private Declare PtrSafe Function OleCreatePictureIndirectAut Lib "oleAut32.dll" Alias "OleCreatePictureIndirect" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
    Private Declare PtrSafe Function OleCreatePictureIndirectPro Lib "olepro32.dll" Alias "OleCreatePictureIndirect" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
    Private Declare PtrSafe Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As LongPtr, ByVal nCount As Long, lpObject As Any) As Long
[COLOR=#008000][B]    'GDI+ APIS.[/B][/COLOR]
    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

[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 

    Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
    Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
    Private Declare Function OleCreatePictureIndirectAut Lib "oleAut32.dll" Alias "OleCreatePictureIndirect" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
    Private Declare Function OleCreatePictureIndirectPro Lib "olepro32.dll" Alias "OleCreatePictureIndirect" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
    Private Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
[COLOR=#008000][B]    'GDI+ APIS.[/B][/COLOR]
    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

[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If

Private Const S_OK = 0


Public Sub ResizeImageFile(ByVal SourceFile As String, ByVal NewFileSize As Long, Optional ByVal DestinationFileCopy As String)

    Dim PicBits() As Byte, tPicInfo As BITMAP
    Dim oPic As StdPicture, oTempPic As StdPicture, oPrevTempPic As StdPicture
    Dim i As Long, j As Long
    
    Set oPic = LoadPicture(SourceFile)
    Call GetObjectAPI(oPic, LenB(tPicInfo), tPicInfo)
    Set oTempPic = CreateThumbnail(oPic, tPicInfo.bmWidth, tPicInfo.bmHeight)
    i = 1: j = 1
    
    If Not oTempPic Is Nothing Then
        Do
            Set oTempPic = CreateThumbnail(oPic, i, j)
            Call GetObjectAPI(oTempPic, LenB(tPicInfo), tPicInfo)
            Erase PicBits
            ReDim PicBits((tPicInfo.bmWidth * tPicInfo.bmHeight * 3) - 1) As Byte
            i = i + 1:     j = j + 1
            Application.StatusBar = "Processing File: " & SourceFile & "  " & tPicInfo.bmWidth * tPicInfo.bmHeight * 3 & " of " & NewFileSize & " Bits."
            DoEvents
            If UBound(PicBits) >= NewFileSize - (NewFileSize / 10) Then Exit Do
            Set oPrevTempPic = oTempPic
        Loop
        
        Application.StatusBar = False
        
        If Len(DestinationFileCopy) Then SourceFile = DestinationFileCopy
        
        SavePicture oPrevTempPic, SourceFile
    Else
        MsgBox "Cannot load file."
    End If

End Sub


Private Function CreateThumbnail(ByVal Image As StdPicture, ByVal Width As Long, ByVal Height As Long) As StdPicture
   
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
        Dim lGDIP As LongPtr, lBitmap As LongPtr, lThumb As LongPtr, hBitmap As LongPtr
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
        Dim lGDIP As Long, lBitmap As Long, lThumb As Long, hBitmap As Long
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If
   
    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)
             Set CreateThumbnail = HandleToPicture(hBitmap, vbPicTypeBitmap)
            GdipDisposeImage lThumb
         End If
         GdipDisposeImage lBitmap
      End If
      GdiplusShutdown lGDIP
   End If
   
   If lRes Then Err.Raise 5, , "Cannot load file."
   
End Function


[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
    Private Function HandleToPicture(ByVal hGDIHandle As LongPtr, ByVal ObjectType As PictureTypeConstants) As StdPicture
        Dim hLib As LongPtr
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
    Private Function HandleToPicture(ByVal hGDIHandle As Long, ByVal ObjectType As PictureTypeConstants) As StdPicture
        Dim hLib As Long
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If
    
    Dim uPicDesc As uPicDesc, IID_IPicture As GUID, oPicture As IPicture
    Dim lRet As Long
   
   With uPicDesc
     .Size = Len(uPicDesc)
     .Type = ObjectType
      .hPic = hGDIHandle
     .hPal = 0
   End With
   
   With IID_IPicture
      .Data1 = &H7BF80981
      .Data2 = &HBF32
      .Data3 = &H101A
      .Data4(0) = &H8B
      .Data4(1) = &HBB
      .Data4(3) = &HAA
      .Data4(5) = &H30
      .Data4(6) = &HC
      .Data4(7) = &HAB
   End With
   
    hLib = LoadLibrary("oleAut32.dll")
    If hLib Then
        lRet = OleCreatePictureIndirectAut(uPicDesc, IID_IPicture, True, oPicture)
    Else
        lRet = OleCreatePictureIndirectPro(uPicDesc, IID_IPicture, True, oPicture)
    End If
    FreeLibrary hLib
    
    If lRet = S_OK Then
        Set HandleToPicture = oPicture
    Else
        Err.Raise 5, , "Cannot Create Picture."
    End If

End Function



2- Usage example:

The Test Macro below will reduce to 50kbs all image files located in ThsWorkbook.Path & "\Images" folder whose size are greater than 50kbs.

Code: 
Sub Test()

    Dim oFSO As Object, oFolder As Object, oFile As Object
    Dim sFolderPath As String
    Dim sResizedFiles() As String
    Dim i As Long
    
    Const NEW_REDUCED_FILE_SIZE = 50000  [B][COLOR=#008000]'bits  <== change new size as required.[/COLOR][/B]
    
    sFolderPath = ThisWorkbook.Path & "\Images"   [B][COLOR=#008000]' <== change image folder path as required.[/COLOR][/B]
    
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    Set oFolder = oFSO.GetFolder(sFolderPath)
    
    For Each oFile In oFolder.Files
        If InStr(1, "jpg jpeg png gif iff bmp svg", oFSO.GetExtensionName(oFile.Path), vbTextCompare) Then
            If oFile.Size >= NEW_REDUCED_FILE_SIZE Then
                Call ResizeImageFile(SourceFile:=sFolderPath & "\" & oFile.Name, NewFileSize:=NEW_REDUCED_FILE_SIZE)
                ReDim Preserve sResizedFiles(i)
                sResizedFiles(i) = sFolderPath & "\" & oFile.Name
                i = i + 1
            End If
        End If
    Next
    
    If Len(Join(sResizedFiles)) > 0 Then
        MsgBox "(" & i & ") - Resized Image File(s) :" & vbNewLine & vbNewLine & Join(sResizedFiles, vbNewLine)
    Else
        MsgBox "No files processed."
    End If
    
End Sub


Note:
The code may take a while to execute if the files are big in size that's why the ResizeImageFile routine updates the StatusBar.

Maybe a better approach is to execute the code from a modeless userform with a label that updates the user on the progress of the resizing operation.
 
Last edited:
Upvote 0

Excel Facts

VLOOKUP to Left?
Use =VLOOKUP(A2,CHOOSE({1,2},$Z$1:$Z$99,$Y$1:$Y$99),2,False) to lookup Y values to left of Z values.
Exactly what I needed! !!!!. Thank you so much.

Now I can run the fastest spreadsheets with images .

:)
 
Upvote 0
@kelly

I am glad I could help and thanks for the feedback.

Just a reminder to anyone using the code to resize the images files; Please, make a copy of the folder containing your images before trying the code so that you keep a backup of your original images.
 
Upvote 0
Jaafar Tribak said:
Hi Kelly,

Adding a progress indicator won't work here because there is no way of knowing how many image files exist beforehand.
Regards.
Click to expand...

Sure, that's what I observed - was thinking there could be a possibility.
 
Upvote 0
Jaafar Tribak said:
Ok- Please ignore the previous main API code and use this one instead :

1- In a Standard Module:
Code: 
Option Explicit

Private Enum PictureTypeConstants
      vbPicTypeNone = 0
      vbPicTypeBitmap = 1
      vbPicTypeMetafile = 2
      vbPicTypeIcon = 3
      vbPicTypeEMetafile = 4
End Enum
  
Private Type BITMAP
    bmType As Long
    bmWidth As Long
    bmHeight As Long
    bmWidthBytes As Long
    bmPlanes As Integer
    bmBitsPixel As Integer
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
        bmBits As LongPtr
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL]
        bmBits As Long
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If
End Type
  
Private Type uPicDesc
    Size As Long
    Type As Long
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
        hPic As LongPtr
        hPal As LongPtr
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL]
       hPic As Long
       hPal As Long
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  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 GdiplusStartupInput
   GdiplusVersion As Long
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
        DebugEventCallback As LongPtr
        SuppressBackgroundThread As LongPtr
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL]
        DebugEventCallback As Long
        SuppressBackgroundThread As Long
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If
   SuppressExternalCodecs As Long
End Type

[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then

    Private Declare PtrSafe Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As LongPtr
    Private Declare PtrSafe Function FreeLibrary Lib "kernel32" (ByVal hLibModule As LongPtr) As Long
    Private Declare PtrSafe Function OleCreatePictureIndirectAut Lib "oleAut32.dll" Alias "OleCreatePictureIndirect" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
    Private Declare PtrSafe Function OleCreatePictureIndirectPro Lib "olepro32.dll" Alias "OleCreatePictureIndirect" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
    Private Declare PtrSafe Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As LongPtr, ByVal nCount As Long, lpObject As Any) As Long
[COLOR=#008000][B]    'GDI+ APIS.[/B][/COLOR]
    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

[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL]

    Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
    Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
    Private Declare Function OleCreatePictureIndirectAut Lib "oleAut32.dll" Alias "OleCreatePictureIndirect" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
    Private Declare Function OleCreatePictureIndirectPro Lib "olepro32.dll" Alias "OleCreatePictureIndirect" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
    Private Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
[COLOR=#008000][B]    'GDI+ APIS.[/B][/COLOR]
    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

[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If

Private Const S_OK = 0


Public Sub ResizeImageFile(ByVal SourceFile As String, ByVal NewFileSize As Long, Optional ByVal DestinationFileCopy As String)

    Dim PicBits() As Byte, tPicInfo As BITMAP
    Dim oPic As StdPicture, oTempPic As StdPicture, oPrevTempPic As StdPicture
    Dim i As Long, j As Long
   
    Set oPic = LoadPicture(SourceFile)
    Call GetObjectAPI(oPic, LenB(tPicInfo), tPicInfo)
    Set oTempPic = CreateThumbnail(oPic, tPicInfo.bmWidth, tPicInfo.bmHeight)
    i = 1: j = 1
   
    If Not oTempPic Is Nothing Then
        Do
            Set oTempPic = CreateThumbnail(oPic, i, j)
            Call GetObjectAPI(oTempPic, LenB(tPicInfo), tPicInfo)
            Erase PicBits
            ReDim PicBits((tPicInfo.bmWidth * tPicInfo.bmHeight * 3) - 1) As Byte
            i = i + 1:     j = j + 1
            Application.StatusBar = "Processing File: " & SourceFile & "  " & tPicInfo.bmWidth * tPicInfo.bmHeight * 3 & " of " & NewFileSize & " Bits."
            DoEvents
            If UBound(PicBits) >= NewFileSize - (NewFileSize / 10) Then Exit Do
            Set oPrevTempPic = oTempPic
        Loop
       
        Application.StatusBar = False
       
        If Len(DestinationFileCopy) Then SourceFile = DestinationFileCopy
       
        SavePicture oPrevTempPic, SourceFile
    Else
        MsgBox "Cannot load file."
    End If

End Sub


Private Function CreateThumbnail(ByVal Image As StdPicture, ByVal Width As Long, ByVal Height As Long) As StdPicture
  
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
        Dim lGDIP As LongPtr, lBitmap As LongPtr, lThumb As LongPtr, hBitmap As LongPtr
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL]
        Dim lGDIP As Long, lBitmap As Long, lThumb As Long, hBitmap As Long
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If
  
    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)
             Set CreateThumbnail = HandleToPicture(hBitmap, vbPicTypeBitmap)
            GdipDisposeImage lThumb
         End If
         GdipDisposeImage lBitmap
      End If
      GdiplusShutdown lGDIP
   End If
  
   If lRes Then Err.Raise 5, , "Cannot load file."
  
End Function


[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
    Private Function HandleToPicture(ByVal hGDIHandle As LongPtr, ByVal ObjectType As PictureTypeConstants) As StdPicture
        Dim hLib As LongPtr
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL]
    Private Function HandleToPicture(ByVal hGDIHandle As Long, ByVal ObjectType As PictureTypeConstants) As StdPicture
        Dim hLib As Long
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If
   
    Dim uPicDesc As uPicDesc, IID_IPicture As GUID, oPicture As IPicture
    Dim lRet As Long
  
   With uPicDesc
     .Size = Len(uPicDesc)
     .Type = ObjectType
      .hPic = hGDIHandle
     .hPal = 0
   End With
  
   With IID_IPicture
      .Data1 = &H7BF80981
      .Data2 = &HBF32
      .Data3 = &H101A
      .Data4(0) = &H8B
      .Data4(1) = &HBB
      .Data4(3) = &HAA
      .Data4(5) = &H30
      .Data4(6) = &HC
      .Data4(7) = &HAB
   End With
  
    hLib = LoadLibrary("oleAut32.dll")
    If hLib Then
        lRet = OleCreatePictureIndirectAut(uPicDesc, IID_IPicture, True, oPicture)
    Else
        lRet = OleCreatePictureIndirectPro(uPicDesc, IID_IPicture, True, oPicture)
    End If
    FreeLibrary hLib
   
    If lRet = S_OK Then
        Set HandleToPicture = oPicture
    Else
        Err.Raise 5, , "Cannot Create Picture."
    End If

End Function



2- Usage example:

The Test Macro below will reduce to 50kbs all image files located in ThsWorkbook.Path & "\Images" folder whose size are greater than 50kbs.

Code: 
Sub Test()

    Dim oFSO As Object, oFolder As Object, oFile As Object
    Dim sFolderPath As String
    Dim sResizedFiles() As String
    Dim i As Long
   
    Const NEW_REDUCED_FILE_SIZE = 50000  [B][COLOR=#008000]'bits  <== change new size as required.[/COLOR][/B]
   
    sFolderPath = ThisWorkbook.Path & "\Images"   [B][COLOR=#008000]' <== change image folder path as required.[/COLOR][/B]
   
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    Set oFolder = oFSO.GetFolder(sFolderPath)
   
    For Each oFile In oFolder.Files
        If InStr(1, "jpg jpeg png gif iff bmp svg", oFSO.GetExtensionName(oFile.Path), vbTextCompare) Then
            If oFile.Size >= NEW_REDUCED_FILE_SIZE Then
                Call ResizeImageFile(SourceFile:=sFolderPath & "\" & oFile.Name, NewFileSize:=NEW_REDUCED_FILE_SIZE)
                ReDim Preserve sResizedFiles(i)
                sResizedFiles(i) = sFolderPath & "\" & oFile.Name
                i = i + 1
            End If
        End If
    Next
   
    If Len(Join(sResizedFiles)) > 0 Then
        MsgBox "(" & i & ") - Resized Image File(s) :" & vbNewLine & vbNewLine & Join(sResizedFiles, vbNewLine)
    Else
        MsgBox "No files processed."
    End If
   
End Sub


Note:
The code may take a while to execute if the files are big in size that's why the ResizeImageFile routine updates the StatusBar.

Maybe a better approach is to execute the code from a modeless userform with a label that updates the user on the progress of the resizing operation.
Click to expand...

Dear Jaafar,

I'm really interested in this solution. I added your codes to a standard module but there are several lines in red:
- lines beginning with "[URL" in almost every procedures
- "Const NEW_REDUCED_FILE_SIZE" and "sFolderPath" within "Sub Test"

Error message is "Compile error: Expected: expression"

Print screen #1:


1578670507567.png


Print screen #2:

1578670647021.png


What could be the problem?

Thanks,
 
Upvote 0
KeepTrying said:
Dear Jaafar,

I'm really interested in this solution. I added your codes to a standard module but there are several lines in red:
- lines beginning with "[URL" in almost every procedures
- "Const NEW_REDUCED_FILE_SIZE" and "sFolderPath" within "Sub Test"

Error message is "Compile error: Expected: expression"

Print screen #1:


View attachment 3694

Print screen #2:

View attachment 3695

What could be the problem?

Thanks,
Click to expand...

Hi KeepTrying,
,
That was because of the new board upgrade messing up the original code.

Here is a clean copy:

1- Standard Module;
VBA Code: 
Option Explicit

Private Enum PictureTypeConstants
      vbPicTypeNone = 0
      vbPicTypeBitmap = 1
      vbPicTypeMetafile = 2
      vbPicTypeIcon = 3
      vbPicTypeEMetafile = 4
End Enum
 
Private Type BITMAP
    bmType As Long
    bmWidth As Long
    bmHeight As Long
    bmWidthBytes As Long
    bmPlanes As Integer
    bmBitsPixel As Integer
    #If VBA7 Then
        bmBits As LongPtr
    #Else
        bmBits As Long
    #End If
End Type
 
Private Type uPicDesc
    Size As Long
    Type As Long
    #If VBA7 Then
        hPic As LongPtr
        hPal As LongPtr
    #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 GdiplusStartupInput
   GdiplusVersion As Long
    #If VBA7 Then
        DebugEventCallback As LongPtr
        SuppressBackgroundThread As LongPtr
    #Else
        DebugEventCallback As Long
        SuppressBackgroundThread As Long
    #End If
   SuppressExternalCodecs As Long
End Type

#If VBA7 Then

    Private Declare PtrSafe Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As LongPtr
    Private Declare PtrSafe Function FreeLibrary Lib "kernel32" (ByVal hLibModule As LongPtr) As Long
    Private Declare PtrSafe Function OleCreatePictureIndirectAut Lib "oleAut32.dll" Alias "OleCreatePictureIndirect" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
    Private Declare PtrSafe Function OleCreatePictureIndirectPro Lib "olepro32.dll" Alias "OleCreatePictureIndirect" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
    Private Declare PtrSafe Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As LongPtr, ByVal nCount As Long, lpObject As Any) As Long
    'GDI+ APIS.
    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

#Else

    Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
    Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
    Private Declare Function OleCreatePictureIndirectAut Lib "oleAut32.dll" Alias "OleCreatePictureIndirect" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
    Private Declare Function OleCreatePictureIndirectPro Lib "olepro32.dll" Alias "OleCreatePictureIndirect" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
    Private Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
    'GDI+ APIS.
    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

#End If

Private Const S_OK = 0

Public Sub ResizeImageFile(ByVal SourceFile As String, ByVal NewFileSize As Long, Optional ByVal DestinationFileCopy As String)

    Dim PicBits() As Byte, tPicInfo As BITMAP
    Dim oPic As StdPicture, oTempPic As StdPicture, oPrevTempPic As StdPicture
    Dim i As Long, j As Long
   
    Set oPic = LoadPicture(SourceFile)
    Call GetObjectAPI(oPic, LenB(tPicInfo), tPicInfo)
    Set oTempPic = CreateThumbnail(oPic, tPicInfo.bmWidth, tPicInfo.bmHeight)
    i = 1: j = 1
   
    If Not oTempPic Is Nothing Then
        Do
            Set oTempPic = CreateThumbnail(oPic, i, j)
            Call GetObjectAPI(oTempPic, LenB(tPicInfo), tPicInfo)
            Erase PicBits
            ReDim PicBits((tPicInfo.bmWidth * tPicInfo.bmHeight * 3) - 1) As Byte
            i = i + 1:     j = j + 1
            Application.StatusBar = "Processing File: " & SourceFile & "  " & tPicInfo.bmWidth * tPicInfo.bmHeight * 3 & " of " & NewFileSize & " Bits."
            DoEvents
            If UBound(PicBits) >= NewFileSize - (NewFileSize / 10) Then Exit Do
            Set oPrevTempPic = oTempPic
        Loop
       
        Application.StatusBar = False
       
        If Len(DestinationFileCopy) Then SourceFile = DestinationFileCopy
       
        SavePicture oPrevTempPic, SourceFile
    Else
        MsgBox "Cannot load file."
    End If

End Sub


Private Function CreateThumbnail(ByVal Image As StdPicture, ByVal Width As Long, ByVal Height As Long) As StdPicture
 
    #If VBA7 Then
        Dim lGDIP As LongPtr, lBitmap As LongPtr, lThumb As LongPtr, hBitmap As LongPtr
    #Else
        Dim lGDIP As Long, lBitmap As Long, lThumb As Long, hBitmap As Long
    #End If
 
    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)
            Set CreateThumbnail = HandleToPicture(hBitmap, vbPicTypeBitmap)
            GdipDisposeImage lThumb
         End If
         GdipDisposeImage lBitmap
      End If
      GdiplusShutdown lGDIP
   End If
 
   If lRes Then Err.Raise 5, , "Cannot load file."
 
End Function


#If VBA7 Then
    Private Function HandleToPicture(ByVal hGDIHandle As LongPtr, ByVal ObjectType As PictureTypeConstants) As StdPicture
        Dim hLib As LongPtr
#Else
    Private Function HandleToPicture(ByVal hGDIHandle As Long, ByVal ObjectType As PictureTypeConstants) As StdPicture
        Dim hLib As Long
#End If
   
    Dim uPicDesc As uPicDesc, IID_IPicture As GUID, oPicture As IPicture
    Dim lRet As Long
 
   With uPicDesc
     .Size = Len(uPicDesc)
     .Type = ObjectType
      .hPic = hGDIHandle
     .hPal = 0
   End With
 
   With IID_IPicture
      .Data1 = &H7BF80981
      .Data2 = &HBF32
      .Data3 = &H101A
      .Data4(0) = &H8B
      .Data4(1) = &HBB
      .Data4(3) = &HAA
      .Data4(5) = &H30
      .Data4(6) = &HC
      .Data4(7) = &HAB
   End With
 
    hLib = LoadLibrary("oleAut32.dll")
    If hLib Then
        lRet = OleCreatePictureIndirectAut(uPicDesc, IID_IPicture, True, oPicture)
    Else
        lRet = OleCreatePictureIndirectPro(uPicDesc, IID_IPicture, True, oPicture)
    End If
    FreeLibrary hLib
   
    If lRet = S_OK Then
        Set HandleToPicture = oPicture
    Else
        Err.Raise 5, , "Cannot Create Picture."
    End If

End Function



2- Test:
VBA Code: 
Option Explicit

Sub Test()

    Dim oFSO As Object, oFolder As Object, oFile As Object
    Dim sFolderPath As String
    Dim sResizedFiles() As String
    Dim i As Long
   
    Const NEW_REDUCED_FILE_SIZE = 50000  'bits  <== change new size as required.
   
    sFolderPath = ThisWorkbook.Path & "\Images"   ' <== change image folder path as required.
   
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    Set oFolder = oFSO.GetFolder(sFolderPath)
   
    For Each oFile In oFolder.Files
        If InStr(1, "jpg jpeg png gif iff bmp svg", oFSO.GetExtensionName(oFile.Path), vbTextCompare) Then
            If oFile.Size >= NEW_REDUCED_FILE_SIZE Then
                Call ResizeImageFile(SourceFile:=sFolderPath & "\" & oFile.Name, NewFileSize:=NEW_REDUCED_FILE_SIZE)
                ReDim Preserve sResizedFiles(i)
                sResizedFiles(i) = sFolderPath & "\" & oFile.Name
                i = i + 1
            End If
        End If
    Next
   
    If Len(Join(sResizedFiles)) > 0 Then
        MsgBox "(" & i & ") - Resized Image File(s) :" & vbNewLine & vbNewLine & Join(sResizedFiles, vbNewLine)
    Else
        MsgBox "No files processed."
    End If
   
End Sub
 
Upvote 0
Jaafar Tribak said:
Hi KeepTrying,
,
That was because of the new board upgrade messing up the original code.

Here is a clean copy:

1- Standard Module;
VBA Code: 
Option Explicit

Private Enum PictureTypeConstants
      vbPicTypeNone = 0
      vbPicTypeBitmap = 1
      vbPicTypeMetafile = 2
      vbPicTypeIcon = 3
      vbPicTypeEMetafile = 4
End Enum

Private Type BITMAP
    bmType As Long
    bmWidth As Long
    bmHeight As Long
    bmWidthBytes As Long
    bmPlanes As Integer
    bmBitsPixel As Integer
    #If VBA7 Then
        bmBits As LongPtr
    #Else
        bmBits As Long
    #End If
End Type

Private Type uPicDesc
    Size As Long
    Type As Long
    #If VBA7 Then
        hPic As LongPtr
        hPal As LongPtr
    #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 GdiplusStartupInput
   GdiplusVersion As Long
    #If VBA7 Then
        DebugEventCallback As LongPtr
        SuppressBackgroundThread As LongPtr
    #Else
        DebugEventCallback As Long
        SuppressBackgroundThread As Long
    #End If
   SuppressExternalCodecs As Long
End Type

#If VBA7 Then

    Private Declare PtrSafe Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As LongPtr
    Private Declare PtrSafe Function FreeLibrary Lib "kernel32" (ByVal hLibModule As LongPtr) As Long
    Private Declare PtrSafe Function OleCreatePictureIndirectAut Lib "oleAut32.dll" Alias "OleCreatePictureIndirect" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
    Private Declare PtrSafe Function OleCreatePictureIndirectPro Lib "olepro32.dll" Alias "OleCreatePictureIndirect" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
    Private Declare PtrSafe Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As LongPtr, ByVal nCount As Long, lpObject As Any) As Long
    'GDI+ APIS.
    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

#Else

    Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
    Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
    Private Declare Function OleCreatePictureIndirectAut Lib "oleAut32.dll" Alias "OleCreatePictureIndirect" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
    Private Declare Function OleCreatePictureIndirectPro Lib "olepro32.dll" Alias "OleCreatePictureIndirect" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
    Private Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
    'GDI+ APIS.
    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

#End If

Private Const S_OK = 0

Public Sub ResizeImageFile(ByVal SourceFile As String, ByVal NewFileSize As Long, Optional ByVal DestinationFileCopy As String)

    Dim PicBits() As Byte, tPicInfo As BITMAP
    Dim oPic As StdPicture, oTempPic As StdPicture, oPrevTempPic As StdPicture
    Dim i As Long, j As Long
  
    Set oPic = LoadPicture(SourceFile)
    Call GetObjectAPI(oPic, LenB(tPicInfo), tPicInfo)
    Set oTempPic = CreateThumbnail(oPic, tPicInfo.bmWidth, tPicInfo.bmHeight)
    i = 1: j = 1
  
    If Not oTempPic Is Nothing Then
        Do
            Set oTempPic = CreateThumbnail(oPic, i, j)
            Call GetObjectAPI(oTempPic, LenB(tPicInfo), tPicInfo)
            Erase PicBits
            ReDim PicBits((tPicInfo.bmWidth * tPicInfo.bmHeight * 3) - 1) As Byte
            i = i + 1:     j = j + 1
            Application.StatusBar = "Processing File: " & SourceFile & "  " & tPicInfo.bmWidth * tPicInfo.bmHeight * 3 & " of " & NewFileSize & " Bits."
            DoEvents
            If UBound(PicBits) >= NewFileSize - (NewFileSize / 10) Then Exit Do
            Set oPrevTempPic = oTempPic
        Loop
      
        Application.StatusBar = False
      
        If Len(DestinationFileCopy) Then SourceFile = DestinationFileCopy
      
        SavePicture oPrevTempPic, SourceFile
    Else
        MsgBox "Cannot load file."
    End If

End Sub


Private Function CreateThumbnail(ByVal Image As StdPicture, ByVal Width As Long, ByVal Height As Long) As StdPicture

    #If VBA7 Then
        Dim lGDIP As LongPtr, lBitmap As LongPtr, lThumb As LongPtr, hBitmap As LongPtr
    #Else
        Dim lGDIP As Long, lBitmap As Long, lThumb As Long, hBitmap As Long
    #End If

    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)
            Set CreateThumbnail = HandleToPicture(hBitmap, vbPicTypeBitmap)
            GdipDisposeImage lThumb
         End If
         GdipDisposeImage lBitmap
      End If
      GdiplusShutdown lGDIP
   End If

   If lRes Then Err.Raise 5, , "Cannot load file."

End Function


#If VBA7 Then
    Private Function HandleToPicture(ByVal hGDIHandle As LongPtr, ByVal ObjectType As PictureTypeConstants) As StdPicture
        Dim hLib As LongPtr
#Else
    Private Function HandleToPicture(ByVal hGDIHandle As Long, ByVal ObjectType As PictureTypeConstants) As StdPicture
        Dim hLib As Long
#End If
  
    Dim uPicDesc As uPicDesc, IID_IPicture As GUID, oPicture As IPicture
    Dim lRet As Long

   With uPicDesc
     .Size = Len(uPicDesc)
     .Type = ObjectType
      .hPic = hGDIHandle
     .hPal = 0
   End With

   With IID_IPicture
      .Data1 = &H7BF80981
      .Data2 = &HBF32
      .Data3 = &H101A
      .Data4(0) = &H8B
      .Data4(1) = &HBB
      .Data4(3) = &HAA
      .Data4(5) = &H30
      .Data4(6) = &HC
      .Data4(7) = &HAB
   End With

    hLib = LoadLibrary("oleAut32.dll")
    If hLib Then
        lRet = OleCreatePictureIndirectAut(uPicDesc, IID_IPicture, True, oPicture)
    Else
        lRet = OleCreatePictureIndirectPro(uPicDesc, IID_IPicture, True, oPicture)
    End If
    FreeLibrary hLib
  
    If lRet = S_OK Then
        Set HandleToPicture = oPicture
    Else
        Err.Raise 5, , "Cannot Create Picture."
    End If

End Function



2- Test:
VBA Code: 
Option Explicit

Sub Test()

    Dim oFSO As Object, oFolder As Object, oFile As Object
    Dim sFolderPath As String
    Dim sResizedFiles() As String
    Dim i As Long
  
    Const NEW_REDUCED_FILE_SIZE = 50000  'bits  <== change new size as required.
  
    sFolderPath = ThisWorkbook.Path & "\Images"   ' <== change image folder path as required.
  
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    Set oFolder = oFSO.GetFolder(sFolderPath)
  
    For Each oFile In oFolder.Files
        If InStr(1, "jpg jpeg png gif iff bmp svg", oFSO.GetExtensionName(oFile.Path), vbTextCompare) Then
            If oFile.Size >= NEW_REDUCED_FILE_SIZE Then
                Call ResizeImageFile(SourceFile:=sFolderPath & "\" & oFile.Name, NewFileSize:=NEW_REDUCED_FILE_SIZE)
                ReDim Preserve sResizedFiles(i)
                sResizedFiles(i) = sFolderPath & "\" & oFile.Name
                i = i + 1
            End If
        End If
    Next
  
    If Len(Join(sResizedFiles)) > 0 Then
        MsgBox "(" & i & ") - Resized Image File(s) :" & vbNewLine & vbNewLine & Join(sResizedFiles, vbNewLine)
    Else
        MsgBox "No files processed."
    End If
  
End Sub
Click to expand...

Hi Jaafar,

Fantastic, great solution as always :) Two comments:
1. How did you add code to the post properly?
2. only for info: After macro ran if I open one of the images I get this message (I use Irfan View as a picture viewer and extension was and remained jpg for my test image):

1578678377707.png


If I hit "No" everything looks fine (resized image with original extension).

Thanks a lot and have a great weekend.
 
Upvote 0
You must log in or register to reply here.

Similar threads

Jaafar Tribak
  • Question
Blurring images using Direct2D & Windows Imaging Component
Replies
3
Views
255
Dan_W
D
C
  • Question
Ton of script in case anyone wants to review, maybe something useful to someone
Replies
0
Views
2K
cizzett
C
S
  • Question
Pass Parameters from VBA to AS400
Replies
0
Views
3K
speed88bump
S
Y
  • Question
SAP - Deal with the "Save As" dialog box with VBA and/or VBS
2
Replies
14
Views
29K
YounesB3
Y

Forum statistics

Threads
1,214,944
Messages
6,122,391
Members
449,080
Latest member
Armadillos

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top