' Creates web-sized and thumbnail-sized pictures from your ' original "JPG" camera photos. Automatically corrects the image ' rotation if your pictures contain the EXIF information ' provided by most digital cameras. Does NOT modify your original ' pictures. Created file names match your originals, but the ' web pictures will have ".JPEG" file extensions and the ' thumbnails will have ".GIF" file extensions. ' Requires the free GFLAx ActiveX object from XNView.com. Option Explicit Const THUMBNAIL_SIZE = 50 Const WEB_SIZE = 640 Main Sub Main() Dim blnRegistered, strFolder, strFiles, strFile, fs, fil 'Register the FileSystem object If Not ((IsRegistered("Scripting.FileSystemObject")) And (IsRegistered("Wscript.Shell"))) Then If MsgBox ("You seem to have a bad or old installation of Microsoft Windows Scripting. I'd like to take you to a Microsoft web page where you can download Scripting Version 5.6. May I launch your browser to take you to the download page?", vbYesNo, "Update Needed") = vbYes Then Select Case OsVersion() Case 0 ws.Run "http://msdn.microsoft.com/downloads/list/webdev.asp?frame=true", 1, False Case 5 ws.Run "http://www.microsoft.com/downloads/details.aspx?FamilyId=C717D943-7E4B-4622-86EB-95A22B832CAA&displaylang=en", 1, False Case Else ws.Run "http://www.microsoft.com/downloads/details.aspx?FamilyId=0A8A18F6-249C-4A72-BFCF-FC6AF26DC390&displaylang=en", 1, False End Select End If MsgBox "After you (or your administrator) are done updating Scripting, you can re-run this program." Exit Sub End If Set fs = CreateObject("Scripting.FileSystemObject") 'Register the GFLAx object MsgBox "This script will need to register and run the ""GFLAx"" ActiveX object, create files, and delete files. If your computer warns you about these actions, you should allow them." blnRegistered = IsRegistered("GflAx.GflAx") If Not blnRegistered Then If fs.FileExists(FileNameInThisDir("GflAx.dll")) Then RegisterServer(FileNameInThisDir("GflAx.dll")) Else MsgBox "You need to get the ""GFLAx"" ActiveX object (GFLAx.dll) from http://www.xnview.com and either install it or place it in the same folder as this script." Exit Sub End If End If If Not IsRegistered("GflAx.GflAx") Then MsgBox "I was unable to temporarily register the GFLAx.dll file. Please have your administrator install the ""GFLAx"" ActiveX component from http://www.xnview.com.", vbOkay, "Error" Exit Sub End If 'Select the folder for processing strFolder = "" If WScript.Arguments.Count = 1 Then If fs.FolderExists(WScript.Arguments(0)) Then strFolder = WScript.Arguments(0) End If End If If strFolder = "" Then strFolder = BrowseForFolder("Location of Pictures") If strFolder = "" Then Exit Sub 'Process all JPG files If Lcase(Right(Wscript.FullName, 12)) = "\wscript.exe" Then CreateObject("Wscript.Shell").Popup "I'll let you know when I'm done...", 5 End If For Each fil In fs.GetFolder(strFolder).Files If UCase(Right(fil.Name, 4)) = ".JPG" Then Status fil.Path CreateWebAndThumbPic fil.Path End If Next 'Clean up by unregistering the DLL If Not blnRegistered Then UnRegisterServer(FileNameInThisDir("GflAx.dll")) 'Let the user know it's done MsgBox "Web and thumbnail-sized pictures are ready! If you don't plan on having your original large JPG photos available for the presentation, you should move them somewhere else." End Sub Sub CreateWebAndThumbPic(strFile) Dim gfx, fs Dim strOrientation, strFileName Dim lngOrientation, lngWidth, lngHeight, lngMax, lngMin, lngDivisor Const AX_JPEG = 1 Const AX_JPG = 1 Const AX_GIF = 2 Const AX_PNG = 3 Set gfx = CreateObject("GflAx.GflAx") Set fs = CreateObject("Scripting.FileSystemObject") 'Load the picture for processing gfx.LoadBitmap strFile 'Correct the orientation strOrientation = gfx.EXIFGetByID(274) If strOrientation <> "" Then lngOrientation = Clng(Left(Right(strOrientation, 2), 1)) Select Case lngOrientation Case 1 'Do nothing Case 2 gfx.FlipHorizontal Case 3 gfx.Rotate 180 Case 4 gfx.FlipVertical Case 5 gfx.FlipVertical gfx.Rotate 90 Case 6 gfx.Rotate 90 Case 7 gfx.FlipHorizontal gfx.Rotate 90 Case 8 gfx.Rotate 270 Case Else 'Do nothing End Select End If 'Make web-sized picture with .JPEG file extension lngWidth = gfx.width lngHeight = gfx.height lngMax = 0 If lngWidth > lngMax Then lngMax = lngWidth If lngHeight > lngMax Then lngMax = lngHeight If lngMax > WEB_SIZE Then lngDivisor = lngMax/WEB_SIZE gfx.Resize lngWidth\lngDivisor, lngHeight\lngDivisor End If gfx.SaveFormat = AX_JPEG 'Same type of image needs to save in different directory or with different base name strFileName = FileNameInTempDir("~image.jpg") gfx.SaveBitmap strFileName fs.CopyFile FileNameInTempDir("~image.jpg"), NewExtension(strFile, "jpeg ") fs.DeleteFile FileNameInTempDir("~image.jpg") 'Make thumbnails lngWidth = gfx.width lngHeight = gfx.height 'Crop the image to a perfect square lngMin = lngWidth If lngHeight < lngMin Then lngMin = lngHeight gfx.ResizeCanvas lngMin, lngMin 'Resize to thumbnail size lngWidth = gfx.width lngHeight = gfx.height lngMax = 0 If lngWidth > lngMax Then lngMax = lngWidth If lngHeight > lngMax Then lngMax = lngHeight If lngMax > THUMBNAIL_SIZE Then lngDivisor = lngMax/THUMBNAIL_SIZE gfx.Resize lngWidth\lngDivisor, lngHeight\lngDivisor End If gfx.SaveFormat = AX_GIF strFileName = NewExtension(strFile, "gif") gfx.SaveBitmap strFileName End Sub Sub RegisterServer(strPath) Dim fs, wsh Const SystemFolder = 1 Const WshNormalFocus = 1 Set wsh = CreateObject("Wscript.Shell") Set fs = CreateObject("Scripting.FileSystemObject") Select Case Lcase(Right(strPath, 4)) Case ".exe" wsh.Run strPath & " /RegServer", WshNormalFocus, True Case ".wsc" wsh.Run "regsvr32.exe /i:""" & strPath & """ """ & fs.GetSpecialFolder(SystemFolder) & "\scrobj.dll""", WshNormalFocus, True Case Else wsh.Run "regsvr32.exe /s """ & strPath & """", WshNormalFocus, True 'wsh.Run "rundll32.exe """ & strPath & """ DllRegisterServer", WshNormalFocus, True End Select End Sub Sub UnRegisterServer(strPath) Dim fs, wsh Const SystemFolder = 1 Const WshNormalFocus = 1 Set wsh = CreateObject("Wscript.Shell") Set fs = CreateObject("Scripting.FileSystemObject") Select Case Lcase(Right(strPath, 4)) Case ".exe" wsh.Run strPath & " /UnRegServer", WshNormalFocus, True Case ".wsc" wsh.Run "regsvr32.exe /u /n /i:""" & strPath & """ """ & fs.GetSpecialFolder(SystemFolder) & "\scrobj.dll""", WshNormalFocus, True Case Else wsh.Run "regsvr32.exe /s /u """ & strPath & """", WshNormalFocus, True 'wsh.Run "rundll32.exe """ & strPath & """ DllUnRegisterServer", WshNormalFocus, True End Select End Sub Function IsRegistered(strObjectName) 'Returns True if object can be created Dim obj On Error Resume Next Set obj = Nothing Set obj = CreateObject(strObjectName) If obj Is Nothing Then IsRegistered = False Else IsRegistered = True Set obj = Nothing End If End Function Function NewExtension(strFullFilePath, strNewExtension) Dim fs Set fs = CreateObject("Scripting.FileSystemObject") strNewExtension = fs.BuildPath(fs.GetParentFolderName(strFullFilePath), fs.GetBaseName(strFullFilePath) & "." & strNewExtension) NewExtension = strNewExtension End Function Function FileNameInTempDir(strFileName) 'As String 'Returns the full path and file name to a file in the user's temporary directory Dim fs 'As Scripting.FileSystemObject Const TemporaryFolder = 2 Set fs = CreateObject("Scripting.FileSystemObject") FileNameInTempDir = fs.GetAbsolutePathName(fs.BuildPath(fs.GetSpecialFolder(TemporaryFolder), strFileName)) End Function Function FileNameInThisDir(strFileName) 'As String 'Returns the complete path and file name to a file in 'the script directory. For example, "trans.log" might 'return "C:\Program Files\Scripts\Database\trans.log" 'if the script was in the "C:\Program Files\Scripts\Database" 'directory. Dim fs 'As Object Set fs = CreateObject("Scripting.FileSystemObject") FileNameInThisDir = fs.GetAbsolutePathName(fs.BuildPath(Wscript.ScriptFullName, "..\" & strFileName)) ''''''''''Clean up Set fs = Nothing End Function Function BrowseForFolder(strPrompt) 'Uses the "Shell.Application" (only present in Win98 and newer) 'to bring up a file/folder selection window. Falls back to an 'ugly input box under Win95. 'Shell32.ShellSpecialFolderConstants Const ssfPERSONAL = 5 'My Documents Const ssfDRIVES = 17 'My Computer Const SFVVO_SHOWALLOBJECTS = 1 Const SFVVO_SHOWEXTENSIONS = 2 Dim sh, fol, fs, lngView, strPath Set sh = CreateObject("Shell.Application") If Instr(TypeName(sh), "Shell") = 0 Then BrowseForFolder = InputBox(strPrompt, "Select Folder", CreateObject("Scripting.FileSystemObject").GetParentFolderName(WScript.ScriptFullName)) Exit Function End If Set fs = CreateObject("Scripting.FileSystemObject") lngView = SFVVO_SHOWALLOBJECTS Or SFVVO_SHOWEXTENSIONS strPath = "" Set fol = sh.BrowseForFolder(&0, strPrompt, lngView, ssfDRIVES) Err.Clear On Error Resume Next strPath = fol.ParentFolder.ParseName(fol.Title).Path 'An error occurs if the user selects a drive instead of a folder If Err.Number <> 0 Then BrowseForFolder = Left(Right(fol.Title, 3), 2) & "\" Else BrowseForFolder = strPath End If End Function Function OsVersion() 'Returns the base number for the OS (4 = Win9x, 5 = 2K/XP, 0 = unknown) Dim lngVersion, strVersion, objWMI, colSystems, objOS On Error Resume Next Err.Clear Set objWMI = GetObject("winmgmts:\\.\root\CIMV2") Set colSystems = objWMI.ExecQuery("SELECT * FROM Win32_OperatingSystem", "WQL", 48) For Each objOS In colSystems strVersion = objOS.Version Next If Err.Number <> 0 Then strVersion = "4" 'Assume lack of WMI means Windows 9X End If If InStr(strVersion, ".") > 1 Then strVersion = Left(strVersion, InStr(strVersion, ".") - 1) End If If IsNumeric(strVersion) Then lngVersion = Clng(strVersion) Else lngVersion = 0 End If OsVersion = lngVersion Set objWMI = Nothing End Function Sub Status(strMessage) If Lcase(Right(Wscript.FullName, 12)) = "\cscript.exe" Then Wscript.Echo strMessage End If End Sub