Resize JPG files to consistent size

OK here we go again with something that Excel was never designed to handle but here goes. My application inserts a picture when the user chooses a location to view from a designated folder. My problem is that these images are getting larger and larger as the reps get better cameras and it is becoming an issue on this end.

My question is,
Is there a way I can have excel resize JPG’s to a consistent size and overwrite the image? I would like to have this so when the user chooses the location it checks the size and if its too big then resize and overwrite it.:rotlaugh:

Kind of like this.
Insert c:\pictures\test.jpg
If c:\pictures\test.jpg.size > 500k then resize and overwrite.:eek:

I would even be open to a module that resized all JPG’s in the folder all at once to a specific size. I was searching a lot and found some examples of using the chart export functionality but was wondering if there is something in the script host object module that might help.

If someone can point me in the right direction as to if it can be done and how to best approach it I can provide more information.

I know, using a measuring tape to drive a nail :doh:

Thanks again as always.

I would use IRFanView for something like that. It has a batch option. You can also Shell() to it from VBA to do some tasks as well.

I've found PixResizer to be a simple way to load folders worth of images and resize them

Paul

When you say size, I am not sure if you mean file size or pixels. The solution would vary accordingly.

If you have to do just one image, I would do something like what I did in this PerfectScript macro for WordPerfect: http://www.wpuniverse.com/vb/showthr...threadid=30690

So you won't have to register to see the code at the site above, it is shown next. You can look at IRFanView's help for Command Line Switches for details on what you can do. The PerfectScript code is a bit similar to VBA so it should not be difficult to see what I did.

Code:

---

//PasteOneGraphic.wcm by Kenneth Hobson, February 27, 2010

//http://tiporama.com/tools/pixels_inches.html
dpi=94    //Change to fit your screen.  Images wider than wPage should fit to magins.

//imageFile="c:\myfiles\pics\onelanebridge.jpg"    //Used for testing.
//Exit if macro was not passed an argument, graphic file's drive:\path\filename.ext.
If (MacroArgs[0]=0)
    MessageBox(;"Macro Ending";"No image  drive:\path\filename.ext was passed.";IconStop!)
    Go(EndNow)
EndIf
imageFile=MacroArgs[1]

//Exit if imageFile does not exist.
If (Not(DoesFileExist(imageFile)))
    MessageBox(;"Image Does Not Exist";imageFile;IconStop!)
    Go(EndNow)
EndIf

//End if IrfanView is not installed.
irfanview="C:\Program Files\IrfanView\i_view32.exe"
irfanview="C:\Program Files (x86)\IrfanView\i_view32.exe"
If (Not(DoesFileExist(irfanview)))
    MessageBox(;"IrfanView Not Found";irfanview;IconStop!)
    Go(EndNow)
EndIf
irfanviewq=""""+irfanview+""""+" "

//Create a temporary TXT filename.
tempdir=EnvVariableGet("temp")+"\"
If (Not(DoesDirectoryExist(tempdir)))
    tempdir=EnvVariableGet("tmp")+"\"
EndIf
If (Not(DoesDirectoryExist(tempdir)))
    tempdir="c:\"
EndIf
tempFile=tempdir+"IrfanView.txt"

//Delete tempFile if it exists.
If (DoesFileExist(tempFile))
    DeleteFile(tempFile;NoPrompts!)
EndIf   

//Create a file to save resized image or image
CopyGraphic=tempdir+"PasteOneGraphic.jpg"

//Delete CopyGraphic if it exists
If (DoesFileExist(CopyGraphic))
    DeleteFile(CopyGraphic;NoPrompts!)
EndIf

//Create the tempFile of image information in IrfanView.
str=q(irfanview)+" "+q(imageFile)+" /info="+q(tempFile)+" /killmesoftly"
AppExecute(str)

//Loop until tempFile is created.
Repeat
    Wait(1)
Until(DoesFileExist(tempFile))

//Create an array with each line from tempFile.
imageInfo[]=FileToArray(tempFile)

//Find out the available wPage and hPage less the margins on the current page.
wPage=ConvertType(?PaperWidth-?MarginRight-?MarginLeft;Number!)/1200
hPage=ConvertType(?PaperLength-?MarginBottom-?MarginTop;Number!)/1200

//Split imageInfo[] to get the parts needed for resizing computations.
dimLine[]=StrParseList(imageInfo[6];" ")
wPixel=dimLine[4]
wInches=wPixel/dpi
hPixel=dimLine[6]
hInches=hPixel/dpi
ratio=ConvertType(wPixel;Number!)/ConvertType(hPixel;Number!)
If (ratio>=1)
    ls="long"
    Else ls="short"
EndIf
resize=" /resize_"+ls+"="
If (wInches>wPage)
    wInches=wPage
    resize=resize+(wInches*dpi)+" /aspectratio /resample"
    else resize=""
EndIf

//Resize if needed and copy the graphic to the clipboard.
str=q(irfanview)+" "+q(imageFile)+resize+" /clipcopy /convert="+CopyGraphic+" /transpcolor=(256,256,256) /killmesoftly"
AppExecute(str)

//Paste after CopyGraphic is created.
Repeat
    Wait(1)
Until(DoesFileExist(CopyGraphic))
EditPaste()

//FileOpen(tempFile)    //Check image info.

Go(EndNow)
Function q(str)
    If (StrPos(str; """")>0)
        Return(str)
    EndIf
    qq=""""
    Return(qq+str+qq)
EndFunc

Names[]=FileToArray("c:\myfiles\wp\Names.txt")
Function FileToArray(vFile)    //Read File into array and return array
    hFile=OpenFile (vFile; Read!; Compatibility!; AnsiText!)
    If (hFile=OpenFile.Error!)
        MessageBox (; "Open File Problem"; "Error processing password '^0' file!";
IconStop!+HasParameters!; vFile)
        Quit
    EndIf
    Count=0
    Wait(1)        //Needed for fast computers.
    FilePosition(hFile; 0; FromBeginning!)
    While (not FileIsEOF (hFile))
        Count = Count+1
        FileRead (hFile; x)
    EndWhile
    FilePosition(hFile; 0; FromBeginning!)
    Declare TempArray[Count]
    x=0
    While (not FileIsEOF (hFile))
        x=x+1
        FileRead (hFile; TempArray[x])
    EndWhile
    CloseFile (hFile)
    Return(TempArray[])
EndFunc

EndNow:

---

I don't know if this suits your purpose but if you select for instance 4 cells wide (i.e. A1:D1) the picture will fit to that width.

Code:

---

Sub PictureInsertB()
   
    Dim pic As Picture
    Dim sPic As String
    Dim rPos As Range
    Dim ws As Worksheet
    Dim shp As Shape
    Dim fMod As Double
   
    Application.ScreenUpdating = False
   
    Set ws = ThisWorkbook.Worksheets("Sheet1")
   
    Set rPos = ws.Range(Selection.Address).Resize(75)
       
    sPic = Application.Dialogs(xlDialogInsertPicture).Show
    If TypeName(Selection) <> "Picture" Then Exit Sub
    Set pic = Selection
   
    fMod = IIf(rPos.Height / pic.Height < rPos.Width / pic.Width, rPos.Height / pic.Height, rPos.Width / pic.Width)
       
    With pic
        .ShapeRange.LockAspectRatio = msoFalse
        .Width = pic.Width * fMod
        .Height = pic.Height * fMod
        .Left = rPos.Left '+ (rPos.Width / 2) - (.Width / 2)
        .Top = rPos.Top '+ (rPos.Height / 2) - (.Height / 2)
    End With
   
    Application.ScreenUpdating = True
End Sub

---

HTH
John

As always, I didn't add enough detail on the solution I was looking for. Oops.

My application works fine to find the right picture from a designated folder, resize it, and place it in the sheet.

The main problem is that the JPG's that the user stores in the folder are becoming very large files. These files get uploaded to the server through the app and I was looking for a way to automatically resize the actual JPG files to a smaller Pixel size (1024x768) and overwrite the JPG file in the users picture folder.

I didn't really think that Excel could do this because it seems way outside its intended capability considering it is manipulating and editing graphic files but wanted to give it a shot.

Our enviroment is so locked down that having an application installed to batch the users pictures probably wouldn't be an option. I can resize them here on the server but everytime the users update their pictures it would involve running the script on this end again.

Hey, I knew I would hit the wall someday with what Excel could do. I am glad we will be moving to an enterprise solution in the next 18 months because what Excel is doing now is truly incredible.
BTW, using Excel 2003 but could move to 2007 if needed.

Thanks all for you help.