' ------------------------------------------------------------------------------------ ' StereoPages.vbs ' ' This script will build a web gallery for viewing stereo photographs using the ' Stereoscope Java Applet from Andreas Petersik (http://www.stereofoto.de/sapplet/). ' Select pairs of L/R pictures in the album and launch the script. ' The resulting gallery is segmented in pages based on the values of the "pageField" ' Custom Field (that is pictures having the same pageField will appear in the same ' page in the gallery). ' The html page is a two-frame page with the left frame used to select the pages. ' Download first the applet from Andreas Petersik's site. ' Modify the values in the block of const(ants) to suits your configuration and needs. ' See: http://perso.wanadoo.fr/myalbum/3D for a gallery built with this script. ' ------------------------------------------------------------------------------------ Option Explicit app.ClearTrace const stereoscopePath = "M:\Images\Stéréo\stereoscope.jar" ' Replace by the full path of the applet 'const stereoscopePath = "D:\WebPages\3D\stereoscope.jar" 'const stereoscopePath = "D:\HTML\StereoScope\stereoscope.jar" ' Replace by the full path of the applet const titleText = "Photo stereo" ' Display String for page title const pictureText = "%C7 - %C1%|%FC" ' Display String for the picture comment const stereoType = "parallel" ' Default viewing mode in the applet const previewSize = 120 ' Size of the preview picture (set to 0 to use thumbnail size) const previewSubFolder = "Thumbnails" ' Sub-folder where the preview pictures will be saved const pageField = "Lieu" const webW = 800 ' Size of the picture for the web const webH = 600 const bUsePictureOffset = True ' Utiliser le Champ personnalisé 'Offset' (à positionner sur l'image droite) const bRebuildPictures = False Const ForReading = 1, ForWriting = 2 Dim alb, pic, pic1, pic2, picNew, picTmp, fso, f, fi, k, nbP, nPrevSize, sPicFile1, sPicFile2, nPageNum, bAlbumWasSaved Dim nbPic, i, w, wT, hT, kR, nbSelPic, sFirstPic, s, sCmt, sFile, rcCrop, sPreviewFile, sLastPageName set alb = app.GetCurrentAlbum Dim outputFileName, sTitle, sOutputPath, baseFileName ' Using the album folder as the default output folder sOutputPath = alb.ExpandMacro( Nothing, "%Af" ) sOutputPath = "D:\WebPages\3D" 'sOutputPath = app.GetFilename( "Select the output folder (default is the album folder)", 2, sOutputPath, "", 0 ) if sOutputPath <> "" then app.trace "Output folder is: " & sOutputPath, -1, TRACE_INFORMATION nPrevSize = previewSize if nPrevSize = 0 then nPrevSize = alb.nThumbSize ' Copy of the Stereoscope Applet java archive in the output folder Set fso = CreateObject("Scripting.FileSystemObject") set f = fso.GetFile( stereoscopePath ) f.copy sOutputPath & "\" & "stereoscope.jar" set f = Nothing ' Keep the 'Saved' state of the album as we are going to add temporary images to it bAlbumWasSaved = alb.Saved nbPic = alb.nbPicture nbSelPic = alb.nbSelectedPicture app.Trace "Pictures selected in this album: " & nbSelPic, -1, TRACE_INFORMATION baseFileName = "StereoPages" outputFileName = sOutputPath & "\" & "index" & ".html" 'app.Trace "Output file = " & outputFileName, -1, TRACE_INFORMATION ' Create the top file Set f = fso.OpenTextFile( outputFileName, ForWriting, True) f.WriteLine "" f.WriteLine "" f.WriteLine "" f.WriteLine " " f.WriteLine " " f.WriteLine " " & alb.sAlbumTitle & "" f.WriteLine "" f.WriteLine "" s = Replace( baseFileName, " ", "%20" ) f.WriteLine " " f.WriteLine " " f.WriteLine "" f.WriteLine "<BODY TEXT=""#000000"" BGCOLOR=""#000000"" LINK=""#0000EE"" VLINK=""#551A8B"" ALINK=""#FF0000"">" f.WriteLine "<p>This page requires a frames capable browser.</p>" f.WriteLine "</body>" f.WriteLine "" f.WriteLine "" f.WriteLine "" f.Close outputFileName = sOutputPath & "\" & baseFileName & "_index.html" app.Trace outputFileName Set fi = fso.OpenTextFile( outputFileName, ForWriting, True) fi.WriteLine "" fi.WriteLine "" fi.WriteLine "" sTitle = alb.ExpandMacro( Nothing, titleText ) fi.WriteLine " " & sTitle & "" fi.WriteLine " " fi.WriteLine " " fi.WriteLine " " fi.WriteLine "" fi.WriteLine "" fi.WriteLine "

" & sTitle & "

" fi.WriteLine "
" set pic1 = Nothing set pic2 = Nothing nbP = 0 kR = 0 sLastPageName = "" nPageNum = 0 ' First find all the pages Dim tabPages(), nbPages, bAddPage, j, tabPageTh() nbPages = 0 for i=0 to nbPic-1 Set pic = alb.GetPicture(i) if not pic is Nothing and pic.bSelected then s = pic.GetCustomField( pageField ) if s <> "" then bAddPage = True for j = 0 to nbPages-1 if tabPages(j) = s then bAddPage = False next if bAddPage then nbPages = nbPages + 1 redim Preserve tabPages(nbPages) tabPages(nbPages-1) = s end if end if end if next redim tabPageTh(nbPages) app.Trace "Found " & nbPages & " pages:" for j = 0 to nbPages-1 app.Trace vbTab & tabPages(j) next ' Now process each page for j = 0 to nbPages-1 'if s <> sLastPageName then if nPageNum <> 0 then ClosePageFile nPageNum nPageNum = nPageNum + 1 sLastPageName = tabPages(j) s = StartPageFile( nPageNum, sLastPageName ) fi.WriteLine "

" & sLastPageName & "


" 'end if ' Process each selected picture for i=0 to nbPic-1 Set pic = alb.GetPicture(i) 'app.Trace "pic#=" & i & "/" &nbPic & vbtab & TypeName(pic) if not pic is Nothing and pic.bSelected and pic.GetCustomField( pageField ) = tabPages(j) then if pic1 is Nothing then set pic1 = pic elseif pic2 is Nothing then set pic2 = pic app.Trace "Generating pair #" & nbP+1, -1, TRACE_INFORMATION app.Trace " Processing pictures '" & pic1.sShortFileName & "' and '" & pic2.sShortFileName & "'..." ' Compute the size of the new picture using the picture size, if applicable, the offset Dim dx, dy, x0, y0, x2, y2, w1, h1 if bUsePictureOffset then GetPictureOffset pic2, dx, dy ' Offset is set on the second picture else dx = 0 dy = 0 end if ' Compute the intersection of the left picture and offset right picture x0 = max( 0, dx ) y0 = max( 0, dy ) x2 = min( pic1.w, dx + pic2.w )-1 y2 = min( pic1.h, dy + pic2.h )-1 w1 = x2 - x0 + 1 h1 = y2 - y0 + 1 's = pic1.GetCustomField( pageField ) 'if s <> sLastPageName then ' if nPageNum <> 0 then ClosePageFile nPageNum ' nPageNum = nPageNum + 1 ' sLastPageName = s ' s = StartPageFile( nPageNum, sLastPageName ) ' fi.WriteLine "

" & sLastPageName & "


" 'end if ' If cropping is activated and set for the first picture, we create the preview picture using the ' first picture thumbnail, otherwise take the selected part and resize it to the thumnail size. sFile = pic1.sShortFileName k = InStrRev( sFile, "." ) sPreviewFile = previewSubFolder & "\" & left( sFile, k-1 ) & "_pv.jpg" sFile = sOutputPath & "\" & sPreviewFile app.Trace vbTab & "Saving preview picture " & sFile set rcCrop = pic1.rcCrop 'if alb.nCropMode <> CropMode_Crop or rcCrop.w = 0 then 'if nPrevSize = alb.nThumbSize then ' pic1.copy -1 ' alb.paste sFile ' set picNew = alb.GetPicture( alb.nbPicture-1 ) 'else ' pic1.ConvertAndResize sFile, TYPE_JPEG, nPrevSize, nPrevSize ' set picNew = alb.AddPicture( sFile ) 'end if 'else if bRebuildPictures or not fso.FileExists(sFile) then pic1.ConvertAndResize2 sFile, TYPE_JPEG, nPrevSize, nPrevSize, RM_BOUNDINGRECT, 0, 0 end if set picNew = alb.AddPicture( sFile ) 'end if set rcCrop = Nothing ' Copy the two pictures to the output folder ' Left picture sPicFile1 = sOutputPath & "\Photos\" & pic1.sShortFileName if bRebuildPictures or not fso.FileExists(sPicFile1) then if not pic1.CopyRect( x0, y0, x0+w1, y0+h1, 0 ) then app.Trace "Error copying first picture", 255, TRACE_ERROR bError = True end if sPicFile1 = ResizePicture( pic1 ) end if ' Right picture sPicFile2 = sOutputPath & "\Photos\" & pic2.sShortFileName if bRebuildPictures or not fso.FileExists(sPicFile2) then if not pic2.CopyRect( x0-dx, y0-dy, x0+w1-dx, y0+h1-dy, 0 ) then app.Trace "Error copying second picture", 255, TRACE_ERROR bError = True end if sPicFile2 = ResizePicture( pic2 ) ' Check that the two resized pictures have the same size (that may cause problems with the stereoscope applet) set picTmp = alb.AddPicture( sPicFile1 ) wT = picTmp.w hT = picTmp.h alb.DeletePicture picTmp set picTmp = Nothing set picTmp = alb.AddPicture( sPicFile2 ) if wT <> picTmp.w or hT <> picTmp.h then app.Trace "Warning! The pictures do not have the same size!", 255, TRACE_WARNING alb.DeletePicture picTmp set picTmp = Nothing else set picTmp = alb.AddPicture( sPicFile1 ) wT = picTmp.w hT = picTmp.h alb.DeletePicture picTmp set picTmp = Nothing end if f.WriteLine "" f.WriteLine "" s = alb.ExpandMacro( pic1, PictureText ) dim T T = Split( s, vbCRLF, -1, 1 ) s = trim(T(0)) f.WriteLine "" 'f.WriteLine " " 'f.WriteLine " " f.WriteLine " " f.WriteLine " " f.WriteLine " " 'f.WriteLine " " f.WriteLine " " f.WriteLine " " f.WriteLine "

" f.WriteLine " " f.WriteLine " If you had a JAVA 1.1 enabled browser, you would see a stereoscopic image here!" f.WriteLine "
So you get a preview version only:" f.WriteLine "

" f.WriteLine " " f.WriteLine "

" f.WriteLine "" f.WriteLine "" f.WriteLine replace( app.ConvertString(alb.ExpandMacro( pic1, PictureText ),0), vbcrlf, "
" ) & "" alb.DeletePicture picNew set picNew = Nothing set pic1 = Nothing set pic2 = Nothing nbP = nbP + 1 end if end if next next 'j ClosePageFile nPageNum 'f.WriteLine "" 'f.WriteLine "" 'f.WriteLine "

" & vbcrlf & "

" & vbcrlf & "
Build with MyAlbum script
" 'f.WriteLine "" 'f.WriteLine "" f.Close fi.WriteLine "
" fi.WriteLine "Built with
" fi.WriteLine "
Simple image cataloger and slideshow." fi.WriteLine "
" fi.WriteLine "" fi.WriteLine "" fi.close alb.Saved = bAlbumWasSaved ' Restore 'Saved' indicator app.Trace "" app.Trace nbP & " pairs of pictures processed.", -1, TRACE_INFORMATION app.Trace "HTML file generation complete !", -1, TRACE_OK ' Launch browser outputFileName = sOutputPath & "\index.html" if nbP > 0 then app.Run outputFileName, True, 0 end if ' No output folder selected '------------------------------------------------------ function ResizePicture( byref pic ) dim tmpPic, sNewFile, nNewWidth, nNewHeight set tmpPic = alb.NewPicture( w1, h1, 24, 0 ) tmpPic.Paste 0, 0 sNewFile = sOutputPath & "\Photos\" & pic.sShortFileName if pic.w > pic.h then nNewWidth = webW nNewHeight = webH else nNewWidth = webH nNewHeight = webW end if app.Trace vbTab & "Resizing picture " & pic.sShortFileName & " in " & sOutputPath call tmpPic.Resize( nNewWidth, nNewHeight, RM_BOUNDINGRECT, 0, 0) tmpPic.Save sNewFile, False alb.DeletePicture tmpPic set tmpPic = Nothing ResizePicture = sNewFile end function function ResizePictureOld( byref pic ) dim sNewFile, nNewWidth, nNewHeight sNewFile = sOutputPath & "\Photos\" & pic.sShortFileName if pic.w > pic.h then nNewWidth = webW nNewHeight = webH else nNewWidth = webH nNewHeight = webW end if app.Trace vbTab & "Resizing picture " & pic.sShortFileName & " in " & sOutputPath if not pic.ConvertAndResize2( sNewFile, TYPE_JPEG, nNewWidth, nNewHeight, RM_BOUNDINGRECT, 0, 0 ) then app.trace "Error resizing picture '" & pic.sShortFileName & "'", -1, TRACE_ERROR end if ResizePicture = sNewFile end function '------------------------------------------------------ function StartPageFile( uPageIndex, sPageTitle ) app.Trace "Generating page #" & uPageIndex & ": " & sPageTitle, -1, TRACE_ARROW dim s, outputFileName s = CStr(uPageIndex) while len(s) < 3 s = "0" & s wend StartPageFile = baseFileName & "_" & s & ".html" outputFileName = sOutputPath & "\" & StartPageFile Set f = fso.OpenTextFile( outputFileName, ForWriting, True) f.WriteLine "" f.WriteLine "" f.WriteLine "" 'sTitle = alb.ExpandMacro( Nothing, titleText ) f.WriteLine " " & sPageTitle & "" f.WriteLine " " f.WriteLine " " f.WriteLine " " f.WriteLine "" f.WriteLine "" f.WriteLine "

" & sPageTitle & "

" f.WriteLine "" end function '------------------------------------------------------ function ClosePageFile( uPageIndex ) f.WriteLine "
" f.WriteLine "

" f.WriteLine "This page uses The Stereoscope Applet by Andreas Petersik
" f.WriteLine "" f.WriteLine "" end function ' ------------------------------------------------------------------------------------ function GetPictureOffset( byref pix, byref xP, byref yP) dim s, T s = pix.GetCustomField( "Offset" ) if s = "" then s = "0,0" else app.Trace " Current offset = " & s end if T = Split( s, ",", -1, 1 ) xP = CInt(T(0)) yP = CInt(T(1)) GetPictureOffset = (xP <> 0) and (yP <> 0) end function ' ------------------------------------------------------------------------------------ function min( a, b ) if a < b then min = a else min = b end if end function function max( a, b ) if a > b then max = a else max = b end if end function