This is a script I wrote to help me add IPTC information to over 1200 images. It contains several techniques you might be able to use in your own VBScripts.
' Based on a script to automate Excel with VBscript by Richard L. Mueller
' Demonstrates several additional functions including
' 1) Launching applications
' 2) using SendKeys to control application
' 3) useing Sleep to pause execution during the script
' 4) Arrays
' I wrote this script to help me update the IPTC data of images
' I had downloaded the data from MySQL and put it in an Excel spreadsheet
' Each line of the spreadsheet contains the file name and the desired IPTC information
' I leverage IrfanView to insert the IPTC information into each photograph
' This IPTC information is later read by the server using PHP when I upload the pictures to my photography web site
' You have a royalty-free right to use, modify, reproduce, and
' distribute this script file in any way you find useful, provided that
' you agree that the copyright owner above has no warranty, obligations,
' or liability for such use.
Option Explicit
Dim objExcel, strExcelPath, objSheet, intRow
dim fileName, pictureTitle, pictureDescription, keywords, categoryID, thisYear, originalDate, filesys
' Bind to Excel object.
On Error Resume Next
Set objExcel = CreateObject("Excel.Application")
If Err.Number <> 0 Then
On Error GoTo 0
WScript.Echo "Excel application not found."
WScript.Quit
End If
On Error GoTo 0
strExcelPath = "C:\Temp\originals\tblPictures.xls"
' Open specified spreadsheet and select the first worksheet.
objExcel.WorkBooks.Open strExcelPath
Set objSheet = objExcel.ActiveWorkbook.Worksheets(1)
dim category(9)
category(1) = "Plants"
category(2) = "Animals"
category(3) = "Landscapes"
category(4) = "Textures"
category(5) = "Structures"
category(6) = "Miscellaneous"
category(7) = "John"
category(8) = "People"
category(9) = "Transportation"
dim WshShell
Set WshShell = WScript.CreateObject("WScript.Shell")
Set filesys = CreateObject("Scripting.FileSystemObject")
'Get copyright symbol - VBScript does not have a way to do an alt-0169 combination
Dim charMap
charMap = WshShell.Run("CharMap")
WScript.Sleep 250
WshShell.AppActivate charMap
WScript.Sleep 250
WshShell.SendKeys "{TAB}{TAB}{RIGHT 3}{DOWN 5}~"
WScript.Sleep 250
WshShell.SendKeys "%F"
WScript.Sleep 250
WshShell.SendKeys "Times New Roman"
WScript.Sleep 250
WshShell.SendKeys "%C"
WScript.Sleep 250
WshShell.SendKeys "%{F4}"
' Iterate through the rows of the spreadsheet after the first, until the
' first blank entry in the first column. For each row, bind to the user
' specified in the first column and set attributes.
intRow = 2
Do While objSheet.Cells(intRow, 1).Value <> ""
originalDate = Mid(objSheet.Cells(intRow, 1).Value, 4, 8)
fileName = "C:\Temp\originals\" & objSheet.Cells(intRow, 1).Value
if filesys.FileExists(fileName) Then
pictureTitle = objSheet.Cells(intRow, 2).Value
categoryID = objSheet.Cells(intRow, 3).Value
pictureDescription = objSheet.Cells(intRow, 4).Value
keywords = objSheet.Cells(intRow, 5).Value
' On Error Resume Next
thisYear = mid(originalDate, 1, 4)
WshShell.Run ("C:\Programs\Graphics\I-View\i_view32.exe " & fileName)
WScript.Sleep 250
WshShell.AppActivate "IrfanView"
WshShell.SendKeys "i", True
WScript.Sleep 250
WshShell.SendKeys "%i", True
WScript.Sleep 250
WshShell.SendKeys "^v " & thisYear & " John A. Marsh, all rights reserved" & "{TAB}", True
WshShell.SendKeys replace(replace(pictureDescription, "(", "{(}"), ")", "{)}") & "{TAB}John A. Marsh{TAB}", True
WshShell.SendKeys pictureTitle & "{TAB}", True
WScript.Sleep 250
'WshShell.SendKeys frmOptions.infoInstructions.Text, True
WshShell.SendKeys "^{TAB}" & keywords, True
WScript.Sleep 250
WshShell.SendKeys "^{TAB}" & category(categoryID), True
WScript.Sleep 250
WshShell.SendKeys "^{TAB}John A. Marsh{TAB}Photographer / Owner{TAB}John A. Marsh{TAB}http://www.johnmarshphotography.com/", True
WScript.Sleep 250
WshShell.SendKeys "^{TAB}" & pictureTitle, True
WScript.Sleep 250
WshShell.SendKeys "{TAB}", True
WshShell.SendKeys thisYear & "{TAB}" & Mid(originalDate, 5, 2) & "{TAB}" & Mid(originalDate, 7, 2) & "{TAB}{TAB}", True
WScript.Sleep 250
WshShell.SendKeys "Durham{TAB}North Carolina, NC{TAB}United States of America, USA{TAB}", True
WshShell.SendKeys "{ENTER}", True
WScript.Sleep 250
WshShell.SendKeys "%o", True
WScript.Sleep 250
WshShell.SendKeys "%{F4}"
WScript.Sleep 250
end if
intRow = intRow + 1
Loop
' Close workbook and quit Excel.
objExcel.ActiveWorkbook.Close
objExcel.Application.Quit
' Clean up.
Set objExcel = Nothing
Set objSheet = Nothing
WScript.Echo "Done"
Sub IrfanviewIPTC(fileName)
'Add IPTC data to image via SendKeys commands to IrfanView
'start application
'Dim appIrfanView
'appIrfanView = Shell("C:\Programs\Graphics\I-View\i_view32.exe " & fileName)
End Sub
