Code Amendment Needed: Browse And Compress An Image Instead Of Compressing Entire Images In A Folder

[kelly mort]

This code was written for me by @Jaafar Tribak long ago.
I use it to compress larger images in a folder
Now I want to tweak it a little bi:

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

This is how I am calling the code to work:

Sub CompressLargeImages()
    Dim oFSO As Object, oFolder As Object, oFile As Object
    Dim sFolderPath$, sResizedFiles() As String, i As Long
    
    Const NEW_REDUCED_FILE_SIZE = 35000
    
    With Application

        sFolderPath = ThisWorkbook.Path & .PathSeparator & "PASSPORT PICTURES" & .PathSeparator

        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 & .PathSeparator & oFile.Name, NewFileSize:=NEW_REDUCED_FILE_SIZE)
                    ReDim Preserve sResizedFiles(i)
                    sResizedFiles(i) = sFolderPath & .PathSeparator & oFile.Name
                    i = i + 1
                End If
            End If
        Next
    End With
End Sub

what I want to do now is to be able to use file explorer to browse for an image and compress it.
I have not been able to figure it out yet
Could someone please help me fix it?

 

[Micron]

You shouldn't need the scripting object if you use the msoFileDialogFilePicker to return the path to the chosen file. I suppose you could eliminate some of that code by
- eliminating the loop (at least the folder loop - you might want to multi select and loop over chosen files)
- restricting the type of displayed file via that Filter property of the dialog. That would enable you to show only files by type and extension.
HTH

 

[kelly mort]

You shouldn't need the scripting object if you use the msoFileDialogFilePicker to return the path to the chosen file. I suppose you could eliminate some of that code by
- eliminating the loop (at least the folder loop - you might want to multi select and loop over chosen files)
- restricting the type of displayed file via that Filter property of the dialog. That would enable you to show only files by type and extension.
HTH

Okay
Thanks
Here I wanna select just one item

Can you please point it out for me by adjusting the above code for me?

 

[Micron]

I would say that the code you'd need to integrate would look like

Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
   .Title = "Select File"
   .AllowMultiSelect = False
   .InitialFileName = ThisWorkbook.Path
   '.Filters.Add "EXCEL", "*.xlsm", 1
   .Filters.Add "Images", "*.jpg; *.jpeg; *.png; *.gif; *.bmp; *.tiff; *.svg", 1
End With

If fd.Show Then
     sFolderPath = fd.SelectedItems(1)
'rest of image handling code here

End If

One pic type in the code is "iff" - maybe that should be tiff?
It looks like integrating it would be a bit of a task - hoping you can manage it.

 

[Jaafar Tribak]

Here is a sanitised version of the previous api code :

In a Standard Module:

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 Win64 Then
        bmBits As LongLong
    #Else
        bmBits As Long
    #End If
End Type
 
Private Type uPicDesc
    Size As Long
    Type As Long
    #If Win64 Then
        hPic As LongLong
        hPal As LongLong
    #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 Win64 Then
        DebugEventCallback As LongLong
        SuppressBackgroundThread As LongLong
    #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
    Private Declare PtrSafe Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) 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
    Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) 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


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

    Const WM_KEYDOWN = &H100
    Const WM_KEYUP = &H101
    Const VK_ESCAPE = &H1B

    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
        Call PostMessage(Application.hwnd, WM_KEYDOWN, VK_ESCAPE, &H0)
        Call PostMessage(Application.hwnd, WM_KEYUP, VK_ESCAPE, &H0)
        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
        Call 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 Win64 Then
        Dim lGDIP As LongLong, lBitmap As LongLong, lThumb As LongLong, hBitmap As LongLong
    #Else
        Dim lGDIP As Long, lBitmap As Long, lThumb As Long, hBitmap As Long
    #End If
 
    Const S_OK = 0
    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 Win64 Then
    Private Function HandleToPicture(ByVal hGDIHandle As LongLong, ByVal ObjectType As PictureTypeConstants) As StdPicture
        Dim hLib As LongLong
#Else
    Private Function HandleToPicture(ByVal hGDIHandle As Long, ByVal ObjectType As PictureTypeConstants) As StdPicture
        Dim hLib As Long
#End If
    Const S_OK = 0
    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
    Call FreeLibrary(hLib)
    If lRet = S_OK Then
        Set HandleToPicture = oPicture
    Else
        Err.Raise 5, , "Cannot Create Picture."
    End If
End Function

To do what you want, you can use the built-in file dialog picker function as suggested by Micron, to choose the image file to be compressed.

Usage example:
The following implementation will create a compressed copy of the chosen image file in the same directory down to roughly 35000 bytes.
If you omit the optional 3rd DestinationFileCopy argument, the original file will be over written !!

Sub Test()
    Const NEW_REDUCED_FILE_SIZE = 35000 'bytes   '<<== change compressed size as needed.
    Dim fd As FileDialog, sFilePathName As String, sDestFile As String
 
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    With fd
        .Title = "Select File"
        .AllowMultiSelect = False
        .InitialFileName = ThisWorkbook.Path
        .Filters.Add "Images", "*.jpg; *.jpeg; *.png; *.gif; *.bmp; *.tiff; *.svg", 1
    End With
    If fd.Show Then
        sFilePathName = fd.SelectedItems(1)
        If FileLen(sFilePathName) >= NEW_REDUCED_FILE_SIZE Then
            sDestFile = Left(sFilePathName, InStrRev(sFilePathName, Application.PathSeparator)) & "Compressed " & Dir(sFilePathName)
            Call ResizeImageFile(SourceFile:=sFilePathName, NewFileSize:=NEW_REDUCED_FILE_SIZE, DestinationFileCopy:=sDestFile)
            MsgBox "Done."
        End If
    End If
End Sub

Edit:
Just for the record. This is image size reduction, not really image compression.

 

[kelly mort]

Okay thanks @Jaafar Tribak
I was about to post tweak I made to get it working through the loop

My question is that with the new api will the previous usage still hold?

That is resizing all images in the folder

 

[Jaafar Tribak]

Okay thanks @Jaafar Tribak
My question is that with the new api will the previous usage still hold?
That is resizing all images in the folder

Yes. It should be ok.

 

[kelly mort]

Yes. It should be ok.

Okay
I will run the test shortly and get you the feedback

I am very grateful for your help and time

 

[kelly mort]

@Jaafar Tribak
The code is working fine
Once again I am very grateful

 

[kelly mort]

This is how I got it working before your new update:

Sub TestCompress()
   Dim fd As Object, sFile$
   Dim strFolderPath, i&, oSubFolder
   Dim oFSO As Object, oFolder As Object, oFile As Object
   Dim sFolderPath$, sResizedFiles() As String
   Const NEW_REDUCED_FILE_SIZE = 35000
   
   Set oFSO = CreateObject("Scripting.FileSystemObject")
   Set fd = Application.FileDialog(msoFileDialogFilePicker)
   
   With fd
       .Title = "Select File"
       .AllowMultiSelect = False
       .InitialFileName = ThisWorkbook.Path
       .Filters.Add "Images", "*.jpg; *.jpeg; *.png; *.gif; *.tiff; *.bmp; *.svg", 1
   End With
   
   If fd.Show Then
       sFile = fd.SelectedItems(1)
       sFolderPath = Left(sFile, InStrRev(sFile, "\"))
       With Application
           Set oFolder = oFSO.GetFolder(sFolderPath)
           For Each oFile In oFolder.Files
               If sFile = oFile Then
                   If oFile.Size >= NEW_REDUCED_FILE_SIZEThen
                       Call ResizeImageFile(SourceFile:=sFolderPath & .PathSeparator & oFile.Name, NewFileSize:=NEW_REDUCED_FILE_SIZE)
                       ReDim Preserve sResizedFiles(i)
                       sResizedFiles(i) = sFolderPath & .PathSeparator& oFile.Name
                       i = i + 1
                   End If
               End If
           Next oFile
       End With
   End If
 
   Set oFSO = Nothing
   Call ClearExcelFolder
End Sub