<%@LANGUAGE="VBSCRIPT" CODEPAGE="65001"%> <% Option Explicit Const Version="2.7" %> <% '-------- '############## 'CONFIGURATION. Const cPageTitle="Ytown Diving Team bildgalleri" 'Page title. Change it at your will. 'IMPORTANT: 'Set the images virtual folder (with the last "/") 'Warning: The security restrictions of ASP.NET do not allow you to use ..'s to move up above the root of the application as defined in IIS. 'If you do that, thumbnails may fail to show up. Use always a relative path to your application root. Const cVirtualPath="images/" Const cSendEmailOnCommentAdded=true 'true or false. set this to true if you want to receive comment notifications. Const cAdminEmail="calle@skepp.com" 'set email address to receive comment notifications. Dim cWritableXMLCommentsFile 'Physical folder where the xml comment files are going to be written. cWritableXMLCommentsFile=Server.Mappath(cVirtualPath) & "\comments.xml" 'Value: a valid physical folder. Must end with "\" 'cosmetic Const cMaxThumbnailsSize=70 ' Thumbnail's width. Values: a valid integer Const cNumberPicturesPerRowDefault=3 'set the default number of thumbails per row. Const cimgPlus="graphics/folder.gif" Const cimgChildNode="graphics/child.gif" Const cimgMinus="graphics/folder_open.gif" Const cNumberRecentComments=10 'language 'I had took language configuration out, to make easier multilingual support %> <% 'funcionality Const cShowEmptyFolders=true 'If a folder doesn't contain files inside, would it be displayed? Const cImageExtensions=".jpg,.gif,.png" 'the system would considerar files with that extension as images 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! Const cHideFoldersPattern="_vti_cnf" 'thumbnail generator 'NEW in 2.6.4 use the file testthumb.aspx to check if you environment supports .NET thumbnail generation! 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 'set here available sizes to display the big picture, separate by coma. Const cAvailableThumbnailSizes="original,200,300,500,600" ' "original" is a reserved word Const cDefaultThumbnailSize="600" 'set value that would appear as 'default' 'Main page text sub WriteMainText() 'write here whatever HTML you would like to add to the main page %> <% end sub 'Image Copyright text(apply to every picture) sub WriteCopyRightText() %> <% end sub 'Parse here the picture name as you wish, to take certain characters out of the display name, for example function ParsePictureName(filepath) Const maxPicNamesize=10 Dim output output=fs.GetBaseName(filepath) output=replace(replace(output,"_"," "),"-"," ") 'change "_" for " ", "-" for " " if len(output)>maxPicNamesize then output=left(output,maxPicNamesize) + ".." ParsePictureName=output end Function 'Do whatever you want then a visitor write a comment (send and email to the admin, for example) sub OnCommentAdded(author,email,text,picturelink) if cSendEmailOnCommentAdded then 'lets send an email using CDONTS (be sure you have installed it in your server) Dim objCDO Set objCDO = Server.CreateObject("CDONTS.NewMail") objCDO.To = cAdminEmail objCDO.From = cAdminEmail objCDO.Subject = "Simple online photo catalogue " & Version & " comment" objCDO.Body = "Author: " & author & vbcrlf & _ "Email: " & email & vbcrlf & _ "Comments: " & text & vbcrlf & _ "Picture: " & vbcrlf & picturelink & _ vbcrlf & "--" & vbcrlf & cPageTitle objCDO.Send Set objCDO = Nothing end if 'here you could trigger other actions when user writes a comment. end sub 'END CONFIGURATION '################# 'FUNCTIONS 'function to write formated output to response object. sub prt(strValue) response.write(strValue) & Vbcrlf end Sub 'get XML document from file or create a new one if it doesn't exist function GetXmlObj() Dim objXML Set objXML = Server.CreateObject("Microsoft.XMLDOM") If objXML.load(cWritableXMLCommentsFile) = False Then objXML.appendChild(objXML.createProcessingInstruction("xml","version=""1.0"" encoding=""utf-8""")) objXML.appendChild(objXML.createElement("comments")) End If set GetXmlObj=objXML end function 'BEGIN SEARCH ENGINE 'Show search engine form sub DisplaySearch() prt cSearchPictures prt "
" prt "" 'prt "" prt "" prt "
" End sub 'Do search Sub DoSearch() Dim output if len(request("search")) then dim result,i result=split(searchPictures(cVirtualPath,request("search")),";") for i=0 to ubound(result) -1 output = output & (i+1) & ". " & ShowResultSearchPicture(result(i)) next if ubound(result)=-1 then prt "

" & cNoResultsFoundFor & " " & request("search") & "

" else prt "
" & output & "
" end if end if End Sub 'search engine function searchPictures(Item, filter) Dim folder,subfolder,file set folder = fs.GetFolder(Server.MapPath(Item)) For each subfolder in folder.SubFolders 'aj added exclusion 16/August/2005 if instr(1,subfolder.name ,cHideFoldersPattern,1)= 0 then searchPictures= searchPictures & searchPictures(Item & subfolder.Name & "/",filter) next for each file in folder.Files if (len(filter)=0 or instr(1,file.Path,filter,1)>0) and instr(1,cImageExtensions,fs.GetExtensionName(file.path),1)>0 then searchPictures=searchPictures & Item & file.Name & ";" next end function 'END SEARCH ENGINE 'Display recent comments 'IDEA: Eliram Haklay Sub displayRecentComments () Dim commentsList,objXML,comment,objXMLcomment,i,startPos,tempWriter Set objXML = GetXmlObj() set commentsList=objXML.selectNodes("/comments/comment") 'we could be using xPath with position()< cNumberRecentComments if we were using MSXML2.DOMDocument.4.0 If commentsList.length > 0 Then startPos=commentsList.length - cNumberRecentComments If startPos<0 Then startPos=0 For i = commentsList.length-1 to startPos step -1 Set comment=objXML.childnodes(1).childnodes(i) Prt "" & cFileName & " " & comment.childnodes(4).text & "
" Prt "
" prt ShowResultPicture(comment.childnodes(4).text) prt "
" Prt "
" Prt FormatCommentsToDisplay(comment) prt "

" Next End If End Sub 'Show picture as result (used in search engine and recent comments display) function ShowResultPicture(path) Dim output if cUseThumbnailFile Then tempWriter=cUseThumbnailFilePath & "?ForceAspect=false&Height=" & cMaxThumbnailsSize & "&Width="& cMaxThumbnailsSize & "&image=" & Server.URLencode(path) else tempWriter=path End If output= "
" output= output & "" &_ "" &_ "
" output= output & "" &_ cViewImage & " - " output= output & "" output= output & cViewFolder output= output & "" output= output & "
" ShowResultPicture=output end function 'format comment output from comment XML comment node function FormatCommentsToDisplay(comment) Dim output output= "
" If Len(comment.childnodes(1).text) then 'display obfuscated email output= output & "" & Server.HtmlEncode(comment.childnodes(0).text) & "" else output= output & Server.HtmlEncode(comment.childnodes(0).text) end if output= output & ", " & cOn & " " & Server.HtmlEncode(comment.childnodes(3).text) & " " & cSaid output= output & "
" & replace(Server.HtmlEncode(comment.childnodes(2).text),chr(10),"
") & "
" output= output & "
" FormatCommentsToDisplay=output end function 'Show individual picture as search result function ShowResultSearchPicture(path) Dim objXml,commentsList,comment,output output= replace(path,request("search"),"" & request("search") & "",1,-1,1) & "
" output= output & "
" output= output & ShowResultPicture(path) output= output & "
" Set objXML = GetXmlObj() set commentsList=objXML.selectNodes("/comments/comment[path=""" & path & """]") if commentsList.length>0 then for each comment in commentsList output= output & "
" output= output & FormatCommentsToDisplay(comment) output= output & "
" next end if output= output & "
" set objXML=nothing ShowResultSearchPicture=output end function 'Gets "next" picture file name 'IDEA: Eliram Haklay Function FindTheNext (FileName) Dim File,folder,foundFile,theNextFile Set folder = fs.GetFolder(Server.MapPath(fs.GetParentFolderName(FileName))) foundFile=0 For each File in folder.Files If instr(1,cImageExtensions,fs.GetExtensionName(File.path),1)>0 then If foundFile=1 Then FindTheNext = File.Name foundFile=0 Exit Function Else If File.Name=fs.GetFileName(FileName) Then foundFile=1 End If End If End If Next FindTheNext="" End Function 'Gets "previous" picture file name 'IDEA: Eliram Haklay Function FindThePrev (FileName) Dim File,foundFile,theNextFile Dim folder: set folder = fs.GetFolder(Server.MapPath(fs.GetParentFolderName(FileName))) theNextFile="" For each File in folder.Files If instr(1,cImageExtensions,fs.GetExtensionName(File.path),1)>0 then If File.Name=fs.GetFileName(FileName) Then FindThePrev=theNextFile Exit Function Else theNextFile=File.Name End If End If Next FindThePrev="" End Function Sub UserCommentsEngine () Dim link,commentsList,objXML,comment,objXMLcomment Set objXML = GetXmlObj() link="?action=displayimage&Item=" & Server.URLencode(request("Item")) Prt "

" & cVisitorComments & "

" Prt "
" 'Save comment author details for other comments in the same session if len(request("author"))> 0 then Session("author")=request("author") if len(request("email"))> 0 then Session("email")=request("email") If len(request("text"))>0 and len(request("author"))>0 then 'author and text fields required ' write comment 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.appendChild(objXML.createElement("path")) objXMLcomment.appendChild(objXML.createElement("image")) objXMLcomment.childNodes(0).text = request("author") objXMLcomment.childNodes(1).text = request("email") objXMLcomment.childNodes(2).text = request("text") objXMLcomment.childNodes(3).text = now() objXMLcomment.childNodes(4).text = request("item") objXML.documentElement.appendChild(objXMLcomment.cloneNode(True)) on error resume next objXML.save(cWritableXMLCommentsFile) if err.number<>0 then Prt ("
" & cErrorSavingCommentTo & " " & cWritableXMLCommentsFile & ".

" & cErrorMessage & " " & err.Description & "
") else Call OnCommentAdded(request("author"),request("email"),request("text"),"http://" & Request.ServerVariables("server_name") & Request.ServerVariables("URL") & "?" & Request.querystring) Prt ("
" & cCommentAdded & "
") end if on error goto 0 end if 'read set commentsList=objXML.selectNodes("/comments/comment[path=""" & request("item") & """]") for each comment in commentsList prt FormatCommentsToDisplay(comment) Next 'write form prt "
" prt "" prt "" prt "" prt "
" & cYourName & "*
" & cYourEmail & "
" & cComments & "*
 
" prt "
" Prt "
" End Sub Function GetComment (PictureName) 'getting the text from the comment file (if exists) Dim fl:fl=Server.MapPath(replace (picturename, fs.GetExtensionName(picturename),"txt")) If fs.FileExists(fl) then Dim file: set File = fs.OpenTextFile(fl, 1) GetComment = File.ReadAll File.Close End If set File=nothing End Function 'Create thumbnails output for a particular virtual path Sub DisplayFiles(VirtualPath) ' Read Comments file to see if there are any comments for this folder Dim commentsList,objXML,comment,objXMLcomment,foundComments,commentFiles,cArray,cA Dim File,Folder,iRow, FileName,nImages,output,i Set objXML = GetXmlObj() Set commentsList=objXML.childnodes(1).childnodes commentFiles="" foundComments=0 for each comment in commentsList If fs.GetParentFolderName(comment.childnodes(4).text) + "/"= VirtualPath Then foundComments=foundComments+1 commentFiles=commentFiles & "," & fs.GetFileName(comment.childnodes(4).text) End If Next cArray = Split(commentFiles, ",") Set folder = fs.GetFolder(Server.MapPath(VirtualPath)) iRow=0 nImages=0 output = output & ": " & cAComments & " / " output = output & ": " & cVComments & "
" 'output=output & "" For each File in folder.Files If instr(1,cImageExtensions,fs.GetExtensionName(File.path),1)>0 then nImages=nImages+1 'If iRow=0 then output=output & "" 'output=output & "" 'If cint(iRow)=cint(session("picsperrow")-1) then 'iRow=0 ' output=output & "" 'Else ' iRow=iRow+1 'End If End if Next 'output=output & "
" output= output & "
" output=output & "" if (fs.FileExists(replace(File.path, fs.GetExtensionName(File.path),"txt")))=true Then output= output & "" end if For each cA in cArray If cA=File.Name Then output= output & "" Exit For End If Next if cUseThumbnailFile then tempWriter=cUseThumbnailFilePath & "?ForceAspect=false&Height=" & cMaxThumbnailsSize & "&Width="& cMaxThumbnailsSize & "&image=" & Server.URLEncode(VirtualPath & File.Name) output=output & "" else output=output & "" end if output=output & "
" & ParsePictureName(File.path) & "
" output=output & "
" 'output=output & "
" Prt "
" Prt "" & Folder.name & " [" & nImages & " " & cImagesShort & "] [" & foundComments & " " & cCommentsShort & "]" 'if cAllowUserChangePicturePerRow then Prt"
" & cPicsPerRow & "
" Prt "
" if nImages= 0 then Prt "

" & cThisFolderHasNoImages & "

" else Prt output end if Set folder=nothing End Sub 'get subfolders from folder (recursive) Sub DisplaySubFolders(Item) Dim subfolder,folder, parentfolder,linktext, preHtml, nImages, File set folder = fs.GetFolder(Server.MapPath(Item)) If folder.subfolders.count > 0 then Prt "" end if End Sub Sub CreateFramesBody() %> <body> <p> Today there are many portals where you can order <strong>digital photo prints</strong>. You can even <strong>connect your online photo album</strong> with some of these portals in order to provide digital photo printing service to your visitors. <br /><br /> By providing <strong>digital photo printing features</strong>, your visitors will be able to select in your online photo album software the pictures they like most, connect to a digital photo service printing provider, and get their printings send to their homes with a couple of clicks. </p> </body> <% End Sub sub displayMainImage() 'create resize image select box Dim selectHtml,i,theNext,thePrev selectHtml="" 'end select box creation if cUseThumbnailFile and cstr(session("targetimgsize"))<>"original" then tempWriter=cUseThumbnailFilePath & "?ForceAspect=False&Width=" & session("targetimgsize") & "&Height=" & session("targetimgsize") & "&image=" & Server.URLEncode(request("item")) else : tempWriter=request("item"): end if Prt "
" Prt "
" Prt "
" Prt "
" thePrev=FindThePrev (request("item")) If len(thePrev) Then Prt "" & " " Prt "" Prt cFileName & " " & fs.GetFilename(request("item")) & "" if cUseThumbnailFile then Prt " -
" & cSetMaximumsize & " " & selectHtml & "
" Prt "
" theNext=FindTheNext (request("item")) If len(theNext) Then Prt "" Prt "
" Prt "
" Prt ("") WriteCopyRightText() 'comments tempWriter=GetComment (request("item")) if len(tempWriter)>0 then Prt "

" & cAuthorComments & "

" & tempWriter & "
" if cAllowUserEnterComments then Call UserCommentsEngine() Prt "
" Prt "
" end sub 'END FUNCTIONS 'MAIN On error resume next 'comment this line for debugging purposes Dim fs Set fs = CreateObject("Scripting.FileSystemObject") Dim strThispage 'important to avoid 405 errors in "post" strThispage= Request.ServerVariables ("SCRIPT_NAME") 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 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 len(session("targetimgsize"))=0 then session("targetimgsize")=cDefaultThumbnailSize %> <%=cPageTitle%> <% Select case request("action") case "displayfolders" Prt("") DisplaySubFolders(cVirtualPath) Prt("") case "displayfiles" Prt("") Call DisplayFiles(request("item")) Prt("") Case "recent" Prt("") displayRecentComments Prt("") case "title" Prt "" %> <% 'Script credits. To remove this, you need to buy a commercial license. Prt "" & cScriptHomepage & "" Prt "" Prt "" case "start" Prt "" WriteMainText() Prt("") case "empty" case "search" Prt("") displaysearch dosearch Prt("") case "displayimage" Prt "" DisplayMainImage Prt "" case "copyright" 'ALERT: Removing or modifying this part without a license is an illegal action. Visit the software homepage in order to purchase a license. %>
Created with the free software ASP Simple Online Photo Album
<% Prt "" case else CreateFramesBody End select Set fs=nothing if err then Prt "

Error: " & err.description + ".

" end if %>