Photoshop VBScript to automatically resize images

Decided to learn Photoshop VBScripting, don’t know why I didn’t do this sooner, I now have scripts to automatically generate my blog thumbnails (as below), and add little Google Maps markers on them (see here).

A few constants to change in the script (edit with Notepad);

• RESIZEWIDTH – thumbnail width
• RESIZEHEIGHT – thumbnail height
• IGNOREVERTICAL – should vertical (portrait) images be ignored (I like to do these manually as I crop them to landscape)
• SUFFIX – thumbnail suffix

To run it, simply place the script in your image folder (make sure to take a backup) and execute the file.
auto-resize-images-v0.1.vbs

Public Const RESIZEWIDTH = 150
Public Const RESIZEHEIGHT = 113

Public Const IGNOREVERTICAL = True
Public Const SUFFIX = "-th"

Dim spath
spath = Mid(WScript.ScriptFullName, 1, InStrRev(WScript.ScriptFullName, "\", -1, vbBinaryCompare))

Dim fso
Set fso = CreateObject("Scripting.FileSystemObject")

Dim foldero
Set foldero = fso.GetFolder(spath)

Dim fileo
Dim sfile

For Each fileo In foldero.Files
'only modify jpg files
sfile = fileo.Name
If InStrRev(sfile, ".jpg", -1, vbTextCompare) = Len(sfile) - 3 Then
resize spath & sfile
End If
Next

MsgBox "Complete."

Sub resize(sfilename)

Set WshShell = WScript.CreateObject("WScript.Shell")
Set colProcessList = GetObject("Winmgmts:").ExecQuery("Select * from Win32_Process")

Dim found
found = False

For Each objProcess In colProcessList
If StrComp(objProcess.Name, "photoshop.exe", vbTextCompare) = 0 Then
found = True
Exit For
End If
Next

Dim appRef
If found Then
Set appRef = GetObject(, "Photoshop.Application")
Else
Set appRef = CreateObject("Photoshop.Application")
End If

Do While appRef.documents.Count
appRef.activeDocument.Close 2 'dont' save
Loop

Dim originalRulerUnits
originalRulerUnits = appRef.Preferences.RulerUnits
appRef.Preferences.RulerUnits = 1 'pixels

Dim docRef
Set docRef = appRef.Open(sfilename)

Dim modified
modified = False

If docRef.Width >= docRef.Height Then 'horizontal photo
If docRef.Width <> RESIZEWIDTH Then 'proceed if not already resized
docRef.ResizeImage RESIZEWIDTH 'preserves aspect ratio
modified = True
End If
Else 'verticle photo
If Not IGNOREVERTICAL Then 'proceed
If docRef.Height <> RESIZEHEIGHT Then 'proceed if not already resized
docRef.ResizeImage , RESIZEHEIGHT 'preserves aspect ratio
modified = True
End If
End If
End If

If modified Then 'only save if the image was modified
Dim jpgSaveOptions
Set jpgSaveOptions = CreateObject("Photoshop.JPEGSaveOptions")
jpgSaveOptions.Quality = 8

'calculate the new file name
Dim newfilename
newfilename = Mid(sfilename, 1, Len(sfilename) - 4) & SUFFIX & ".jpg"

docRef.SaveAs newfilename, jpgSaveOptions, True, 2 'for psLowercase
End If

docRef.Close 2 'dont' save

appRef.Preferences.RulerUnits = originalRulerUnits

End Sub