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?

 

[Jaafar Tribak]

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

Glad you got this working in the end and thanks for the feedback.

This is how I got it working before your new update

You no longer need to iterate the files in the folder if you use my last code update. (post#5)

 

[kelly mort]

If you omit the optional 3rd DestinationFileCopy argument, the original file will be over written !!

Hi @Jaafar Tribak

If I want to move the resized (compressed) image to the “passport pictures” folder:

Path ThisWorknook.Path & “\passport pictures\”

How do I do that?

 

[kelly mort]

Hi @Jaafar Tribak

If I want to move the resized (compressed) image to the “passport pictures” folder:

Path ThisWorknook.Path & “\passport pictures\”

How do I do that?

Okay I have been able to fix that by changing this line :

Left(sFilePathName, InStrRev(sFilePathName, Application.PathSeparator))

To

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

The next thing is that I want the naming of the compressed or resized image to come from a variable.

I did that but I was not able to assign the file extension to the resized image
So I created and unknown file which is not usable

How do I get around that?

 

[kelly mort]

Okay I did it

I introduced two variables:

rFileName = Dir(sFilePathName)
ext = Right(rFileName, Len(rFileName) + 1 - InStrRev(rFileName), “.”))

To get the file extension

I think I am cool to go now