VBA Image Compressing Code Amendment Needed

kelly mort

kelly mort

Well-known Member
Joined
Apr 10, 2017
Messages
2,169
Office Version
  1. 2016
Platform
  1. Windows
This code was written for me by @Jaafar Tribak .

I want to update it at the line below but I am not able to do it as I want.

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

Instead of compressing from the parent folder, "PASSPORT PICTURES", I have children folders in the parent folder and I want to get them compressed as well.

How do I switch the path ( sFolderPath ) to point to each child folder and get compressed?

Code: 
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

Thanks in advance
 

Excel Facts

How to find 2nd largest value in a column?
MAX finds the largest value. =LARGE(A:A,2) will find the second largest. =SMALL(A:A,3) will find the third smallest
Sort by date Sort by votes
This is the rest of the code (completecode) written by @Jaafar Tribak
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

I did a few google search and found some codes and adjusted the sub as below:

Code: 
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
    
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    
    Dim mFolder, oSubfolder, mFile, queue As Collection
    Set queue = New Collection
    
    With Application
        sFolderPath = ThisWorkbook.Path & .PathSeparator & "PASSPORT PICTURES" '& .PathSeparator
        queue.Add oFSO.GetFolder(sFolderPath)
        'Set oFolder = oFSO.GetFolder(sFolderPath)
        
        Do While queue.Count > 0
            Set oFolder = queue(1)
            queue.Remove 1 'dequeue
            '...insert any folder processing code here...
            For Each oSubfolder In oFolder.SubFolders
                queue.Add oSubfolder 'enqueue
            Next oSubfolder
            
            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
            
        Loop
    End With
End Sub

But when I run it, I get the error message:
Run-time error '53': File not found

And this line is highlighted

Code: 
Set oPic = LoadPicture(SourceFile)
 
Upvote 0
With the help of great people like @GWteB in this thread:
www.mrexcel.com

VBA Code To Switch Path Dynamically For Subfolders In A Parent Folder

I have this code, which I copied from this same platform at: https://www.mrexcel.com/board/threads/vba-to-check-if-folder-has-subfolder-in-it.846645/post-4120560 written by @AlphaFrog . Which means that I am able to determine if there is/are subfolder(s) in my mainfolder or not. If there...
www.mrexcel.com www.mrexcel.com
and other sources, I have been able to get the code working as below:::

Code: 
Sub CompressLargeImages()
    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")
    
    With Application
        sFolderPath = ThisWorkbook.Path & .PathSeparator & "PASSPORT PICTURES" & .PathSeparator
        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 oFile
    End With
    
    If (oFolder.SubFolders.Count > 0) Then
        With Application
            For Each oSubFolder In oFolder.SubFolders
                sFolderPath = oSubFolder.Path
                For Each oFile In oSubFolder.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 oFile
            Next oSubFolder
        End With
    End If
    Set oFSO = Nothing
End Sub

Thanks to all those you helped out. I am very grateful
 
Upvote 0
Solution
You must log in or register to reply here.

Similar threads

kelly mort
  • Solved
Code Amendment Needed: Browse And Compress An Image Instead Of Compressing Entire Images In A Folder
2
Replies
13
Views
1K
kelly mort
kelly mort
J
  • Question Question
Merge all pdf files from a folder into single PDF using VBA
2
Replies
10
Views
3K
Dan_W
D
N
  • Solved
Code to open csv file using ws.QueryTables.Add failing
Replies
5
Views
839
Domenic
D
C
  • Question Question
VBA code to generate a list of files and sizes in subfolders
Replies
6
Views
3K
classmaz
C
Pinaceous
  • Question Question
VBA Get File Then Open
Replies
6
Views
566
frabulator
frabulator

Forum statistics

Threads
1,223,275
Messages
6,171,121
Members
452,381
Latest member
Nova88

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