'************************************** ' Name: Convert and Compress Images to J ' PG ' Description:Drag and Drop multiple ima ' ges of different formats directly onto t ' his script to convert them all to JPG im ' age files. This project uses the Windows Image Acquisition Object. ' By: A_X_O ' ' ' Inputs:None ' ' Returns:None ' 'Assumes:None ' 'Side Effects:None '************************************** ' ' '--------------------------------------- ' ---------------------------------------- ' '+++++++++++++++++++++++++++++++++++++++ ' ++++++++++++++++++++++++++++++++++++++++ ' ' Demonstration: Windows 10, Windows Im ' age Acquisition ' '+++++++++++++++++++++++++++++++++++++++ ' ++++++++++++++++++++++++++++++++++++++++ ' ' ' ' Purpose : VBScript Windows Image Acqu ' isition ' ' -------------------------------------- ' ------------------------ ' ' Creation Date : 20/03/2018 [dd/mm/yyy ' y] ' ' Version : 1.0 ' ' Designer : Fabian ' ' ' '####################################### ' ######################################## ' ' MODIFICATION HISTORY ' '--------------------------------------- ' ---------------------------------------- ' ' Version : 1:0 20/03/2018 Create the S ' ample ' ' Version : 1:1 26/03/2018 Fix Compress ' ion Fault ' ' ' '--------------------------------------- ' ---------------------------------------- ' ' Public Const wiaFormatBMP = "{B96B3CAB-0728-11D3-9D7B-0000F81EF32E}" ' Fix: Bit_Map_Picture Constant Public Const wiaFormatPNG = "{B96B3CAF-0728-11D3-9D7B-0000F81EF32E}" ' Fix: Portable Network Graphic Constant Public Const wiaFormatGIF = "{B96B3CB0-0728-11D3-9D7B-0000F81EF32E}" ' Fix: Graphics_Interchange_Format Constant Public Const wiaFormatJPEG = "{B96B3CAE-0728-11D3-9D7B-0000F81EF32E}" ' Fix: Joint_Photographic_Experts_Group Constant Public Const wiaFormatTIFF = "{B96B3CB1-0728-11D3-9D7B-0000F81EF32E}" ' Fix: Tagged_Image_File_Format Constant ' Public Const DIR_JPEG = "\JPEG_DIR\" ' Constant OutPut Directory Path Public Const DeskDir = "Desktop" ' Constant Special Folder Public Const IMGQUAL = 25 ' Constant JPG Quality Public Const ImageExt = ".jpg" ' Constant JPG Extention ' Dim WshShell ' Memory Dimentions For Windows Scripting Host - Shell Dim FSO ' Memory Dimentions For File System Object ' Dim IP ' Memory Dimentions WIA - Image Process Dim IMG ' Memory Dimentions For New Image File ' Dim Args ' Memory Dimentions For WScript Arguents Dim iCounter ' Memory Dimentions For Dropped Files Dim StrMyDesktop ' Memory Dimentions For Special Folder Name Dim RetVal ' Memory Dimentions For Create Folder Function Dim JPGFolder ' Memory Dimentions For JPG Directory Dim JPGDir ' Memory Dimentions For JPG Directory ' Set IMG = WScript.CreateObject("WIA.ImageFile") ' Create Windows Image Acquistition Object - Image Set IP = WScript.CreateObject("WIA.ImageProcess") ' Create Windows Image Acquistition Object - Image Process ' Set WshShell = WScript.CreateObject("Wscript.Shell") ' Create Windows Script Host Object Set FSO = CreateObject("Scripting.FileSystemObject") ' Create Windows File System Object ' Set Args = WScript.Arguments ' Put Each Dropped File From The WScript Arguments Into An Array ' StrMyDesktop = WshShell.SpecialFolders(DeskDir) ' Get The Path Of The Desktop ' JPGDir = (StrMyDesktop & DIR_JPEG) ' Build The Path Of The Output Directory ' For iCounter = 0 To Args.Count -1 ' Loop Through Each Dropped Image File That Has Been Dropped ' If Args(iCounter) <> VbNullString Then ' Validate Each Argument ' If FSO.FolderExists(JPGDir) Then ' Output Directory Already Exists ' Call ConvertImages(Args(iCounter), IMGQUAL) ' Start Processing Images ' Else ' Output Directory Doesn't Exist, So Create It ' Set JPGFolder = FSO.CreateFolder(StrMyDesktop & DIR_JPEG) ' Create Output Directory ' WScript.Sleep 1000 ' Allow The System Som Time To Create The Folder ' Call ConvertImages(Args(iCounter), IMGQUAL) ' End If ' Else ' WScript.Quit ' End If ' Next ' Public Sub ConvertImages(ByRef ImagePath, ByVal ImageQuality) ' Accept Images With The Path And Quality On Error Resume Next ' Dim ImageName ' Routine Dimentions Dim NewJPG Dim FPOS Dim LPOS Dim FirstTrim ' IMG.LoadFile ImagePath ' Put Each dropped Image Into The IMG Variable ' If InStrRev((ImagePath),".", -1, 1) Then ' Extract Only The Name Of The Image From The Image Path ' LPOS = instrRev((ImagePath),".", -1, 1) ' FirstTrim = Mid((ImagePath),1, (LPOS)-1) ' FPOS = InStrRev((FirstTrim),"\", -1, 1) ' ImageName = Mid((FirstTrim), (FPOS)+1, Len(FirstTrim)) ' NewJPG = (JPGDir & ImageName & ImageExt) ' Set The Destination Of The New JPG File To The New Output Dir With A JPG Extention ' End If ' If IMG.FormatID <> wiaFormatJPEG Then ' Check The Image Current Extention ' While IP.Filters.Count > 0 ' Remove All Previous Filters From The Process ' IP.Filters.Remove 1 ' Wend ' IP.Filters.Add IP.FilterInfos("Convert").FilterID ' Add A New Filter ' With IP.Filters(1) ' .Properties("FormatID").Value = wiaFormatJPEG ' Apply The New Filters .Properties("Quality").Value = IMGQUAL ' Set Compression ' End With ' Set IMG = IP.Apply(IMG) ' Save The Images ' IMG.SaveFile NewJPG ' End If ' Exit Sub ' End Sub ' Clean Up. ' Set IMG = Nothing Set IP = Nothing ' Set WshShell = Nothing Set FSO = Nothing ' Set Args = Nothing ' ' '