' Creates a gallery page for your pictures. You MUST ' have thumbnails and photos in the same folder and ' related items MUST have identical base names. Option Explicit Const GALLERY_FILE = "index.html" Main Sub Main() Dim fs, fol, fils, fil, list() Dim strPath, strPictureExtension, strThumbnailExtension, strTitle, strFile, strContent Dim intCount Dim blnZero '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") 'Select the folder for processing strPath = "" If WScript.Arguments.Count = 1 Then If fs.FolderExists(WScript.Arguments(0)) Then strPath = WScript.Arguments(0) End If End If If strPath = "" Then strPath = BrowseForFolder("Location of Pictures:") If strPath = "" Then Exit Sub 'Get the picture file type strPictureExtension = InputBox("What is the extension (file type) of the (large) pictures?", "Picture Type", ".jpg") If strPictureExtension = "" Then Exit Sub If Left(strPictureExtension, 1) <> "." Then strPictureExtension = "." & strPictureExtension strPictureExtension = UCase(strPictureExtension) 'Get the thumbnail file type strThumbnailExtension = InputBox("What is the extension (file type) of the (small) thumbnails?", "Thumbnail Type", ".jpeg") If strThumbnailExtension = "" Then Exit Sub If Left(strThumbnailExtension, 1) <> "." Then strThumbnailExtension = "." & strThumbnailExtension strThumbnailExtension = UCase(strThumbnailExtension) 'Get the title If ((Len(fs.GetBaseName(strPath)) > 2) And (Instr(fs.GetBaseName(strPath), " ") = 0)) Then strTitle = Left(fs.GetBaseName(strPath), 1) For intCount = 2 To Len(fs.GetBaseName(strPath)) If InStr("ABCDEFGHIJKLMNOPQRSTUVWXYZ", Mid(fs.GetBaseName(strPath), intCount, 1)) <> 0 Then strTitle = strTitle & " " & Mid(fs.GetBaseName(strPath), intCount, 1) Else strTitle = strTitle & Mid(fs.GetBaseName(strPath), intCount, 1) End If Next Else strTitle = fs.GetBaseName(strPath) End If strTitle = InputBox("Enter the title for this presentation:", "Title", strTitle) 'Create a list of picture/thumbnail pairs Set fol = fs.GetFolder(strPath) Set fils = fol.Files ReDim list(0) blnZero = True Status "Reading file names:" For Each fil In fils Status vbTab & fil.Name strFile = fs.BuildPath(fs.GetParentFolderName(fil.Path),fs.GetBaseName(fil.Name) & strPictureExtension) If fs.FileExists(strFile) Then strFile = fs.BuildPath(fs.GetParentFolderName(fil.Path),fs.GetBaseName(fil.Name) & strThumbnailExtension) If fs.FileExists(strFile) Then If Not BaseNameInArray(list, strFile) Then If Not blnZero Then ReDim Preserve list(UBound(list) + 1) End If list(UBound(list)) = fs.GetBaseName(strFile) blnZero = False End If End If End If Next If blnZero Then MsgBox "I couldn't locate matching pairs of " & strPictureExtension & " and " & strThumbnailExtension & " files in """ & strPath & """." Exit Sub End If SortAscending list 'Create the content strContent = "" strContent = strContent & vbCrLf & "" & strTitle & "" strContent = strContent & vbCrLf & "

" & strTitle & "

" strContent = strContent & vbCrLf & "Click a picture to see the full-sized version" strContent = strContent & vbCrLf & "

" For intCount = LBound(list) To UBound(list) strContent = strContent & vbCrLf & " " Next strContent = strContent & vbCrLf & "" strContent = strContent & vbCrLf & "" String2File strContent, fs.BuildPath(strPath, GALLERY_FILE) 'Let the user know it's done WScript.Echo fs.BuildPath(strPath, GALLERY_FILE) & " has been created." End Sub Function BaseNameInArray(varArray, strFileName) Dim fs, strElement, strBase, blnInArray Set fs = CreateObject("Scripting.FileSystemObject") blnInArray = False strBase = Lcase(fs.GetBaseName(strFileName)) For Each strElement In varArray If Lcase(fs.GetBaseName(strElement)) = strBase Then blnInArray = True Exit For End If Next BaseNameInArray = blnInArray End Function Sub SortAscending(strArray) Dim blnChanged 'As Boolean Dim strBuffer 'As String Dim intCounter 'As Integer blnChanged = True Do Until Not blnChanged blnChanged = False For intCounter = Lbound(strArray) + 1 to Ubound(strArray) If strArray(intCounter -1) > strArray(intCounter) Then blnChanged = True strBuffer = strArray(intCounter -1) strArray(intCounter -1) = strArray(intCounter) strArray(intCounter) = strBuffer End If Next Loop End Sub Sub String2File(strData, strFileName) 'Writes a string to a file Dim fs 'As Scripting.FileSystemObject Dim ts 'As Scripting.TextStream Dim lngChar, strBlock, intChar Const ForWriting = 2 Set fs = CreateObject("Scripting.FileSystemObject") Set ts = fs.OpenTextFile(strFileName, ForWriting, True) Err.Clear On Error Resume Next ts.Write strData If Err.Number <> 0 Then 'Must have hit one of the "problem characters" between 128 and 159 For lngChar = 1 To Len(strData) Step 100 Err.Clear ts.Write Mid(strData, lngChar, 100) If Err.Number <> 0 Then 'This block of 100 must have the problem. Write them one-at-a-time strBlock = Mid(strData, lngChar, 100) For intChar = 1 To Len(strBlock) ts.Write Chr(255 And AscW(Mid(strBlock, intChar))) Next End If Next End If ts.Close 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 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