Compress images with vba code

kelly mort

Well-known Member
Joined
Apr 10, 2017
Messages
1,616
HelloWorld,

I have the feeling there is a way to compress image files with a vba script. If anyone agrees to that can we take up that challenge?


Basically, I will be compressing from a folder. And will like the smallest size possible.

Say below 100kb .

Thanks in advance
Kelly
 

kelly mort

Well-known Member
Joined
Apr 10, 2017
Messages
1,616
So I have been able to search and come across these codes.

I don't reallyunderstand them. But I have the feeling they can be tweaked to my needs. Can someone with that skills fix it for me? By compress I mean reduce in bytes not dimensions.

Thanks

Code:
Sub CompressPic()
Code:
[COLOR=#333333][FONT='inherit']    If TypeName(Selection) = "Picture" Then[/FONT][/COLOR]
[COLOR=#333333][FONT='inherit']        Application.SendKeys "%a~"[/FONT][/COLOR]
[COLOR=#333333][FONT='inherit']        Application.CommandBars.ExecuteMso "PicturesCompress"[/FONT][/COLOR]
[COLOR=#333333][FONT='inherit']    End If[/FONT][/COLOR]

[COLOR=#333333][FONT='inherit']End Sub

[/FONT][/COLOR]



Code:
Code:
][COLOR=#660066][FONT=inherit]Public[/FONT][/COLOR][COLOR=#660066][FONT=inherit]Sub[/FONT][/COLOR][COLOR=#660066][FONT=inherit]ResizeAndCompressSelectedImages[/FONT][/COLOR][COLOR=#666600][FONT=inherit]()[/FONT][/COLOR][COLOR=#000000][FONT=inherit]
    [/FONT][/COLOR][COLOR=#008800][FONT=inherit]'   Store selected images before we start '[/FONT][/COLOR][COLOR=#000000][FONT=inherit]
    [/FONT][/COLOR][COLOR=#660066][FONT=inherit]Dim[/FONT][/COLOR][COLOR=#000000][FONT=inherit] oShape [/FONT][/COLOR][COLOR=#660066][FONT=inherit]As[/FONT][/COLOR][COLOR=#660066][FONT=inherit]Shape[/FONT][/COLOR][COLOR=#000000][FONT=inherit]
    [/FONT][/COLOR][COLOR=#660066][FONT=inherit]Dim[/FONT][/COLOR][COLOR=#000000][FONT=inherit] cShapes [/FONT][/COLOR][COLOR=#660066][FONT=inherit]As[/FONT][/COLOR][COLOR=#660066][FONT=inherit]New[/FONT][/COLOR][COLOR=#660066][FONT=inherit]Collection[/FONT][/COLOR][COLOR=#000000][FONT=inherit]
    [/FONT][/COLOR][COLOR=#660066][FONT=inherit]For[/FONT][/COLOR][COLOR=#660066][FONT=inherit]Each[/FONT][/COLOR][COLOR=#000000][FONT=inherit] oShape [/FONT][/COLOR][COLOR=#660066][FONT=inherit]In[/FONT][/COLOR][COLOR=#660066][FONT=inherit]ActiveWindow[/FONT][/COLOR][COLOR=#666600][FONT=inherit].[/FONT][/COLOR][COLOR=#660066][FONT=inherit]Selection[/FONT][/COLOR][COLOR=#666600][FONT=inherit].[/FONT][/COLOR][COLOR=#660066][FONT=inherit]ShapeRange[/FONT][/COLOR][COLOR=#000000][FONT=inherit]
        [/FONT][/COLOR][COLOR=#660066][FONT=inherit]If[/FONT][/COLOR][COLOR=#000000][FONT=inherit] oShape[/FONT][/COLOR][COLOR=#666600][FONT=inherit].[/FONT][/COLOR][COLOR=#660066][FONT=inherit]Type[/FONT][/COLOR][COLOR=#666600][FONT=inherit]=[/FONT][/COLOR][COLOR=#000000][FONT=inherit] msoPicture [/FONT][/COLOR][COLOR=#660066][FONT=inherit]Then[/FONT][/COLOR][COLOR=#000000][FONT=inherit] cShapes[/FONT][/COLOR][COLOR=#666600][FONT=inherit].[/FONT][/COLOR][COLOR=#660066][FONT=inherit]Add[/FONT][/COLOR][COLOR=#000000][FONT=inherit] oShape
    [/FONT][/COLOR][COLOR=#660066][FONT=inherit]Next[/FONT][/COLOR][COLOR=#000000][FONT=inherit] oShape
    
    [/FONT][/COLOR][COLOR=#008800][FONT=inherit]'   Now, reduce the resolution of all of the selected
    '[/FONT][/COLOR][COLOR=#000000][FONT=inherit]   shapes[/FONT][/COLOR][COLOR=#666600][FONT=inherit],[/FONT][/COLOR][COLOR=#000000][FONT=inherit] one at a time
    [/FONT][/COLOR][COLOR=#660066][FONT=inherit]Dim[/FONT][/COLOR][COLOR=#000000][FONT=inherit] prevWidth [/FONT][/COLOR][COLOR=#660066][FONT=inherit]As[/FONT][/COLOR][COLOR=#660066][FONT=inherit]Single[/FONT][/COLOR][COLOR=#000000][FONT=inherit]
    [/FONT][/COLOR][COLOR=#660066][FONT=inherit]Dim[/FONT][/COLOR][COLOR=#000000][FONT=inherit] prevHeight [/FONT][/COLOR][COLOR=#660066][FONT=inherit]As[/FONT][/COLOR][COLOR=#660066][FONT=inherit]Single[/FONT][/COLOR][COLOR=#000000][FONT=inherit]
    [/FONT][/COLOR][COLOR=#660066][FONT=inherit]For[/FONT][/COLOR][COLOR=#660066][FONT=inherit]Each[/FONT][/COLOR][COLOR=#000000][FONT=inherit] oShape [/FONT][/COLOR][COLOR=#660066][FONT=inherit]In[/FONT][/COLOR][COLOR=#000000][FONT=inherit] cShapes
        prevWidth [/FONT][/COLOR][COLOR=#666600][FONT=inherit]=[/FONT][/COLOR][COLOR=#000000][FONT=inherit] oShape[/FONT][/COLOR][COLOR=#666600][FONT=inherit].[/FONT][/COLOR][COLOR=#000000][FONT=inherit]width[/FONT][/COLOR][COLOR=#666600][FONT=inherit]:[/FONT][/COLOR][COLOR=#000000][FONT=inherit] prevHeight [/FONT][/COLOR][COLOR=#666600][FONT=inherit]=[/FONT][/COLOR][COLOR=#000000][FONT=inherit] oShape[/FONT][/COLOR][COLOR=#666600][FONT=inherit].[/FONT][/COLOR][COLOR=#000000][FONT=inherit]height
        oShape[/FONT][/COLOR][COLOR=#666600][FONT=inherit].[/FONT][/COLOR][COLOR=#660066][FONT=inherit]LockAspectRatio[/FONT][/COLOR][COLOR=#666600][FONT=inherit]=[/FONT][/COLOR][COLOR=#000000][FONT=inherit] msoTrue
        oShape[/FONT][/COLOR][COLOR=#666600][FONT=inherit].[/FONT][/COLOR][COLOR=#000000][FONT=inherit]width [/FONT][/COLOR][COLOR=#666600][FONT=inherit]=[/FONT][/COLOR][COLOR=#006666][FONT=inherit]40[/FONT][/COLOR][COLOR=#008800][FONT=inherit]'   Something small '[/FONT][/COLOR][COLOR=#000000][FONT=inherit]
        oShape[/FONT][/COLOR][COLOR=#666600][FONT=inherit].[/FONT][/COLOR][COLOR=#660066][FONT=inherit]Copy[/FONT][/COLOR][COLOR=#000000][FONT=inherit]
        [/FONT][/COLOR][COLOR=#660066][FONT=inherit]ActiveWindow[/FONT][/COLOR][COLOR=#666600][FONT=inherit].[/FONT][/COLOR][COLOR=#660066][FONT=inherit]View[/FONT][/COLOR][COLOR=#666600][FONT=inherit].[/FONT][/COLOR][COLOR=#660066][FONT=inherit]PasteSpecial[/FONT][/COLOR][COLOR=#000000][FONT=inherit] ppPastePNG
        [/FONT][/COLOR][COLOR=#660066][FONT=inherit]With[/FONT][/COLOR][COLOR=#660066][FONT=inherit]ActiveWindow[/FONT][/COLOR][COLOR=#666600][FONT=inherit].[/FONT][/COLOR][COLOR=#660066][FONT=inherit]Selection[/FONT][/COLOR][COLOR=#666600][FONT=inherit].[/FONT][/COLOR][COLOR=#660066][FONT=inherit]ShapeRange[/FONT][/COLOR][COLOR=#666600][FONT=inherit]([/FONT][/COLOR][COLOR=#006666][FONT=inherit]1[/FONT][/COLOR][COLOR=#666600][FONT=inherit])[/FONT][/COLOR][COLOR=#000000][FONT=inherit]
            [/FONT][/COLOR][COLOR=#666600][FONT=inherit].[/FONT][/COLOR][COLOR=#660066][FONT=inherit]Left[/FONT][/COLOR][COLOR=#666600][FONT=inherit]=[/FONT][/COLOR][COLOR=#000000][FONT=inherit] oShape[/FONT][/COLOR][COLOR=#666600][FONT=inherit].[/FONT][/COLOR][COLOR=#666600][FONT=inherit].[/FONT][/COLOR][COLOR=#660066][FONT=inherit]Top[/FONT][/COLOR][COLOR=#666600][FONT=inherit]=[/FONT][/COLOR][COLOR=#000000][FONT=inherit] oShape[/FONT][/COLOR][COLOR=#666600][FONT=inherit].[/FONT][/COLOR][COLOR=#660066][FONT=inherit]Top[/FONT][/COLOR][COLOR=#000000][FONT=inherit]
            [/FONT][/COLOR][COLOR=#666600][FONT=inherit].[/FONT][/COLOR][COLOR=#000000][FONT=inherit]width [/FONT][/COLOR][COLOR=#666600][FONT=inherit]=[/FONT][/COLOR][COLOR=#000000][FONT=inherit] prevWidth[/FONT][/COLOR][COLOR=#666600][FONT=inherit]:[/FONT][/COLOR][COLOR=#000000][FONT=inherit]
            [/FONT][/COLOR][COLOR=#666600][FONT=inherit].[/FONT][/COLOR][COLOR=#000000][FONT=inherit]height [/FONT][/COLOR][COLOR=#666600][FONT=inherit]=[/FONT][/COLOR][COLOR=#000000][FONT=inherit] prevHeight
        [/FONT][/COLOR][COLOR=#660066][FONT=inherit]End[/FONT][/COLOR][COLOR=#660066][FONT=inherit]With[/FONT][/COLOR][COLOR=#000000][FONT=inherit]
        oShape[/FONT][/COLOR][COLOR=#666600][FONT=inherit].[/FONT][/COLOR][COLOR=#660066][FONT=inherit]Delete[/FONT][/COLOR][COLOR=#000000][FONT=inherit]
    [/FONT][/COLOR][COLOR=#660066][FONT=inherit]Next[/FONT][/COLOR][COLOR=#000000][FONT=inherit] oShape
[/FONT][/COLOR][COLOR=#660066][FONT=inherit]End[/FONT][/COLOR][COLOR=#660066][FONT=inherit]Sub
[/FONT][/COLOR]
 

kelly mort

Well-known Member
Joined
Apr 10, 2017
Messages
1,616
This is the code that loads the images. So when I print the worksheet, (I print through a loop which can take up say 100 counters ) the file size grows . I have no idea why. That's why I need to compress image before run the loop. Thanks

Code:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim fPath As String, sFile$
If Target = Me.[h9] Then
    fPath = ThisWorkbook.Path & "" & Me.CmbTerm.Text
    sFile = Dir(fPath & "" & Right(Me.[h9].Text, 3) & ".*")
    If sFile <> vbNullString Then
      Me.Image1.Picture = LoadPicture(fPath & "" & sFile)
    Else
        Me.Image1.Picture = LoadPicture("")
    End If
    If Err.Number = 53 Then Me.Image1.Picture = LoadPicture("")
End If
End Sub
 

Forum statistics

Threads
1,081,415
Messages
5,358,533
Members
400,502
Latest member
price83

Some videos you may like

This Week's Hot Topics

  • VBA (Userform)
    Hi All, I just would like to know why my code isn't working. Here is my VBA code: [CODE=vba]Private Sub OKButton_Click() Dim i As Integer...
  • List box that changes fill color
    Hello, I have gone through so many pages trying to figure this out. I have a 2020 calendar that depending on the day needs to have a certain...
  • Remove duplicates and retain one. Cross-linked cases
    Hi all I ran out of google keywords to use and still couldn't find a reference how to achieve the results of a single count. It would be great if...
  • VBA Copy and Paste With Duplicates
    Hello All, I'm in need of some input. My VBA skills are sub-par at best. I've assembled this code from basic research and it works but is...
  • Macro
    is it possible for a macro to run if the active cell value is different to the value above it
  • IF DATE and TIME
    I currently use this to check if date has passed but i also need to set a time on it too. Is it possible? [CODE=vba]=IF(B:B>TODAY(),"Not...
Top