<%@ LANGUAGE="VBScript"%>
<%
Option Explicit
Const Version="2.4"
%>
<%
'--------
'##############
'CONFIGURATION.
Const cPageTitle="Simple online photo catalog 2.4" 'Page title. Change it at your will.
'paths
Const cVirtualPath="images/" 'IMPORTANT: Set the images virtual folder (with the last "/")
Dim cWritableXMLCommentsFolder 'Physical folder where the xml comment files are going to be written.
cWritableXMLCommentsFolder=Server.Mappath(cVirtualPath) & "\" 'Value: a valid physical folder. Must end with "\"
'cosmetic
Const cMaxThumbnailsSize=70 ' Thumbnail's width. Values: a valid integer
Const clayoutType=1 'Values: 1,2,3
Const cNumberPicturesPerRowDefault=2 'set the default number of thumbails per row.
Const cimgPlus="plus.gif"
Const cimgChildNode="child.gif"
Const cimgMinus="minus.gif"
Const cAComments="author c."
Const cVComments="visitor c."
'funcionality
Const cShowEmptyFolders=true 'If a folder doesn't contain files inside, would it be displayed?
Const cImageExtensions=".jpg,.gif,.png"
Const cAllowUserChangePicturePerRow=true 'allow visitor to change the number of pictures he visualize per row
Const cAllowUserEnterComments=true 'allow visitor to add comments to the pics. You will need write access permit to comments file!
'thumbnail generator
Const cUseThumbnailFile=true 'Values: true or false. Set to true if you are using a server page to create the thumbnail (if your server has .NET Framework installed)
Const cUseThumbnailFilePath="thumbnail.aspx" 'path to server page that will generate the thumbnail
Const cAvailableThumbnailSizes="200,300,500,700" 'set here available sizes to display the big picture, separate by coma.
'Main page text
sub WriteMainText()
'write here whatever HTML you would like to add to the main page
%>
Welcome to the Simple Online Photo Catalog demo page. You may change this welcome text to feet your needs.
If you find this little script useful, you may want to rate it. Thank you very much.
<%
end sub
'Parse here picture name as you wish
function ParsePictureName(originalName)
Const maxPicNamesize=10
Dim output
output=left(replace(originalName,"_"," "),len(replace(originalName,"_"," "))-4) 'change "_" for " " and take off file extension
if len(output)>maxPicNamesize then output=left(output,maxPicNamesize) + ".."
ParsePictureName=output
End Function
'END CONFIGURATION
'#################
On error resume next
Dim fs
Set fs = CreateObject("Scripting.FileSystemObject")
Dim strThispage 'important to avoid 405 errors in "post"
strThispage= Request.ServerVariables ("SCRIPT_NAME")
Sub prt(strValue)
response.write(strValue) & Vbcrlf
End Sub
Dim sizeValues
sizeValues = split(cAvailableThumbnailSizes,",") 'converting valid image values to array
Dim tempWriter 'use to store temporal values along the script
Dim IDcounter 'to assing unique ID's
IDcounter=0
Sub UserCommentsEngine ()
Dim link,commentsList,objXML,comment,objXMLcomment,XmlFileComments
XmlFileComments=cWritableXMLCommentsFolder & replace(replace(request("Item"), right(request("Item"),4),".xml"),"/","_")
Set objXML = Server.CreateObject("Microsoft.XMLDOM")
If objXML.load(XmlFileComments) = False Then
objXML.appendChild(objXML.createProcessingInstruction("xml","version=""1.0"""))
objXML.appendChild(objXML.createElement("comments"))
End If
link="?action=displayimage&Filename=" & Server.URLencode(request("Filename")) & "&Item=" & Server.URLencode(request("Item"))
Prt "
Visitor Comments:
"
Prt "
"
if request("write")="yes" then
prt ""
else
If len(request("text"))>0 then 'write
Set objXMLcomment = objXML.createElement("comment")
objXMLcomment.appendChild(objXML.createElement("author"))
objXMLcomment.appendChild(objXML.createElement("email"))
objXMLcomment.appendChild(objXML.createElement("text"))
objXMLcomment.appendChild(objXML.createElement("date"))
objXMLcomment.childNodes(0).text = request("author")
objXMLcomment.childNodes(1).text = request("email")
objXMLcomment.childNodes(2).text = request("text")
objXMLcomment.childNodes(3).text = now()
objXML.documentElement.appendChild(objXMLcomment.cloneNode(True))
on error resume next
objXML.save(XmlFileComments)
if err then
Prt ("
Error saving comment to " & XmlFileComments & ".
Error message: " & err.Description & "
")
else
Prt ("
Comment added!!
")
end if
on error goto 0
else
prt "add a comment "
end if
End if
'read
if fs.FileExists(XmlFileComments) then
If objXML.load(XmlFileComments) then
Set commentsList=objXML.childnodes(1).childnodes
prt "
"
for each comment in commentsList
prt "
"
if len(comment.childnodes(1).text) then
prt "" & Server.HtmlEncode(comment.childnodes(0).text) & ""
else
prt Server.HtmlEncode(comment.childnodes(0).text)
end if
prt ", on " & Server.HtmlEncode(comment.childnodes(3).text) & " said:
"
End Sub
Function GetComment (PictureName)
'getting the text from the comment file (if exists)
Dim fl, File
fl=Server.MapPath(replace (picturename, right(picturename,4),".txt"))
If fs.FileExists(fl) then
set File = fs.OpenTextFile(fl, 1)
GetComment = File.ReadAll
File.Close
End If
set File=nothing
End Function
Sub DisplayFiles(VirtualPath)
Dim File,Folder,iRow, FileName,nImages,output,i
Set folder = fs.GetFolder(Server.MapPath(VirtualPath))
iRow=0
nImages=0
For each File in folder.Files
If instr(lcase(cImageExtensions),lcase(right(File.path, 3)))>0 then
nImages=nImages+1
If iRow=0 then output=output & "
"
If cint(iRow)=cint(session("picsperrow")-1) then
iRow=0
output=output & "
"
Else
iRow=iRow+1
End If
End if
Next
Prt "
"
Prt ("Current folder: " & Folder.name & "[" & nImages &" images]")
if cAllowUserChangePicturePerRow then Prt(" ")
Prt "
"
Prt("
")
Prt(output)
Prt("
")
if nImages= 0 then Prt("
This folder has no images.
")
Set folder=nothing
End Sub
'get subfolders from folder (recursive)
Sub DisplaySubFolders(Item)
Dim subfolder,folder, parentfolder,linktext, preHtml
set folder = fs.GetFolder(Server.MapPath(Item))
If folder.subfolders.count > 0 then
Prt "
"
For each subfolder in folder.SubFolders
preHtml=""
IDcounter=IDcounter+1
linktext=" " & subfolder.name &""
if (subfolder.SubFolders.Count > 0) or (subfolder.Files.Count > 0) or cShowEmptyFolders=true then
tempWriter=""
if subfolder.SubFolders.count > 0 then
preHtml = ""
preHtml = preHtml + ""
tempWriter="[" & subfolder.SubFolders.count & " sub]"
elseif subfolder.Files.Count = 0 then
tempWriter=" [empty]"
end if
Prt "
"
end if
End Sub
Sub CreateFramesBody()
%>
<%
End Sub
if isnumeric(request("picsperrow")) and len(request("picsperrow")) > 0 then session("picsperrow")=cint(request("picsperrow"))
if not isnumeric(session("picsperrow")) or len(session("picsperrow"))=0 then session("picsperrow")=cNumberPicturesPerRowDefault
if len(request("targetimgsize")) > 0 then session("targetimgsize")=request("targetimgsize")
if not isnumeric(session("targetimgsize")) or len(session("targetimgsize"))=0 then session("targetimgsize")="original"
%>
<%=cPageTitle%>
<%
Select case request("action")
case "displayfolders"
Prt("")
DisplaySubFolders(cVirtualPath)
Prt("")
case "displayfiles"
Prt("")
Call DisplayFiles(request("item"))
Prt("")
case "title"
Prt("")
Prt("help")
Prt("" & cPageTitle & "")
Prt("")
case "start"
Prt("")
WriteMainText()
Prt("")
case "empty"
case "displayimage"
Prt("")
tempWriter=""
if cUseThumbnailFile and cstr(session("targetimgsize"))<>"original" then tempWriter=cUseThumbnailFilePath & "?ForceAspect=False&Width=" & session("targetimgsize") & "&Height=" & session("targetimgsize") & "&image="
'create select box
Dim selectHtml,i
selectHtml=""
Prt "
"
if cUseThumbnailFile then Prt("")
Prt ("")
Prt "File name: " & request("Filename") & ""
'comments
tempWriter=GetComment (request("item"))
if len(tempWriter)>0 then Prt "
Author comments:
" & tempWriter & "
"
if cAllowUserEnterComments then Call UserCommentsEngine()
Prt "
"
Prt("")
case else
CreateFramesBody
End select
Set fs=nothing
if err then
Prt "
Error: " & err.description + ". Check the config settings. Check you have MSXML installed in your system
Visitor Comments:
" Prt "Error message: " & err.Description & "
" end if End if 'read if fs.FileExists(XmlFileComments) then If objXML.load(XmlFileComments) then Set commentsList=objXML.childnodes(1).childnodes prt "
" for each comment in commentsList prt "- "
if len(comment.childnodes(1).text) then
prt "" & Server.HtmlEncode(comment.childnodes(0).text) & ""
else
prt Server.HtmlEncode(comment.childnodes(0).text)
end if
prt ", on " & Server.HtmlEncode(comment.childnodes(3).text) & " said:
"
prt "- " & replace(Server.HtmlEncode(comment.childnodes(2).text),chr(10),"
"
next
prt "
" else prt "") & "
Error reading XML comments file
" end if end if Prt "