'Gus Mueller, June 15th 2001, modified Jan 2nd 2004 postSourcePath="K:\spies031230\t" postDestPath="K:\spies031230\tout" call FixEmail(postSourcePath, postDestPath) function FixEmail(strSourcePath, strDestPath) 'recursive replacement of mailto: links with links to a web form called /ran/feedback.php 'which accepts a subject parameter 'based on a sync program Gus Mueller, May 25 2001 'Jan 2 2004 dim strOut dim fso, folders, files, thissourcefolder, thissourcefile, thissourcesubfolder, thisSourceFileName, thisDestPath, thisSourceFolderName dim dtmSourceDate, dtmDestDate set fso=createobject("scripting.filesystemobject") set thissourcefolder=fso.getfolder(strSourcePath) for each thissourcesubfolder in thissourcefolder.subfolders thisSourceFolderName=thissourcesubfolder.name thisDestPath=strDestPath & "/" & thisSourceFolderName if fso.folderexists(thisDestPath) then call FixEmail(strSourcePath & "/" & thisSourceFolderName, thisDestPath) else fso.createfolder(thisDestPath) call FixEmail(strSourcePath & "/" & thisSourceFolderName, thisDestPath) end if next for each thissourcefile in thissourcefolder.files dtmSourceDate=thissourcefile.DateLastModified thisSourceFileName=thissourcefile.name strOut=strOut & thisSourceFileName & "
" thisDestPath=strDestPath & "/" & thisSourceFileName if instr(thisSourceFileName, ".htm")>0 or instr(thisSourceFileName, ".html")>0 or instr(thisSourceFileName, ".shtml")>0 or instr(thisSourceFileName, ".php")>0 then 'calculate depth strInterimFolders=mid(strDestPath, len(postDestPath)+1) strInterimFolders=replace(strInterimFolders, "\", "/") strRanPath="ran/" if left(strInterimFolders, 5)="/ran/" then 'keep paths small in /ran strInterimFolders=mid(strInterimFolders, 5) strRanPath="" end if if left(strInterimFolders, 8)="/forests" then 'keep paths small in /forests strInterimFolders=mid(strInterimFolders, 9) strRanPath="" end if slashcount=0 climb="" 'here i count /s to calculate how high up to send the href to get to the top level (and then down into /ran) for r=1 to len(strInterimFolders) if mid(strInterimFolders, r, 1)="/" then r=r+1 climb=climb + "../" end if next mailpath=climb & strRanPath & "feedback.php" '& chr(13) & strInterimFolders & chr(13) set filThis= fso.opentextfile(strSourcePath & "/" & thisSourceFileName, 1, true) if not filThis.atendofstream then strFile=filThis.readall end if filThis.close strFile=replace(strFile, "mailto:gus@spies.com", mailpath) strFile=replace(strFile, "mailto:tetraphis@yahoo.com", mailpath) 'by Goop, I mean the identifiable strings on either side of the Subject, if part of the old mailto: strStartGoop="feedback.php?subject=" strEndGoop= chr(34) & ">" intEmailGoopStart=instr(1, strFile, strStartGoop) if intEmailGoopStart>0 then intEmailGoopEnd=instr(intEmailGoopStart+len(strStartGoop), strFile, strEndGoop) if intEmailGoopEnd>0 then strEmailGoop=mid(strFile, intEmailGoopStart+len(strStartGoop), intEmailGoopEnd-(intEmailGoopStart+len(strStartGoop))) strEmailGoopOrig=strEmailGoop if strEmailGoop<>"" then strEmailGoop=replace(strEmailGoop, " ", "+") end if strFile=replace(strFile,strEmailGoopOrig, strEmailGoop) 'strFile=strFile & chr(13) & strEmailGoopOrig & chr(13) & chr(13) & intEmailGoopStart & chr(13) & intEmailGoopEnd & chr(13) & len(strFile)-intEmailGoopEnd end if end if set filThis=fso.opentextfile(strDestPath & "\" & thisSourceFileName, 2, true) call filThis.write(strFile) filThis.close end if next set thissourcefile=nothing set thissourcesubfolder=nothing set thissourcefolder=nothing set fso=nothing SynchronizePaths=strOut end function