ASP Source Code: MartinLoopers - default.asp
<%@ language = "vbscript" %>
<%
option explicit
Response.Buffer = True
%>
<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN" "http://www.w3.org/TR/REC-html40/loose.dtd">
<!--#include Virtual="/incFiles/adovbs.inc"-->
<%
'Photo Album with Thumbnails and Captions by Allen Mulvey 05-2000
dim tbl
dim conn
dim rs
dim strSQL
dim VisitorCount
dim PageID
dim flag
dim FSO
dim fs
dim Pass
dim subPath
dim topPath
dim topLevel
dim HeaderTitle
dim FolderTitle
dim Caption
dim Body
dim strconn
dim i
dim j
dim arr
dim arrSize
dim navStr
dim tmp
dim root
dim gifsize
'============================================================
' Edit the definitions in this section and
' change the mailto at the bottom of the page
' ******** Define the default top level photo folder
topLevel="Photos"
topPath=server.MapPath(topLevel)
i = InStrRev(topPath,"\")
' ******** Define a FileDSN or a DSN-less connection
'strconn = "DRIVER={Microsoft Access Driver (*.mdb)};DBQ=" & Server.MapPath("Tables") & "\loopers.mdb"
'strconn = "FileDSN=" & Mid(topPath,1,i) & "tables\gallery.dsn"
strconn = "DRIVER={Microsoft Access Driver (*.mdb)};DBQ=c:\sites\Single22\amulvey\database\loopers.mdb;"
'============================================================
i = InStrRev(topPath,"\")
'Get the root path
root = Mid(topPath,1,i)
subPath = Request("subPath")
subPath = Replace(subPath,"/","\")
if subPath = "" then
subPath=topPath
HeaderTitle = topLevel
else
Set FSO = CreateObject("Scripting.FileSystemObject")
if FSO.FolderExists(subpath) = False then
subPath=topPath
HeaderTitle = topLevel
end if
set FSO = nothing
end If
PageID = Mid(subPath,i+1)
arr = split(subPath,"\",-1,1)
arrSize = uBound(arr)
Pass = 1
sub toHTML()
dim i
i = len(Body)
'Strip trailing blank lines
while (right(Body,1) = chr(13)) or (right(Body,1) = chr(10))
str = left(Body,i-1)
i = i-1
wend
'Change newlines to HTML paragraphs and breaks
Body = Replace(Body,vbNewLine & vbNewLine,"<p>")
Body = Replace(Body,vbNewLine,"<br>")
end sub
sub getCaption(cPath,cName,flg)
'flg = 0 return first line only
'flg = 1 return full text
'flg = 2 return full text with first line as header
on error resume next
dim cap1
dim FSO1
Set FSO1 = CreateObject("Scripting.FileSystemObject")
set cap1 = FSO1.OpenTextFile(cPath & "\" & cName & ".txt")
if err.number = 0 then
flag = true
Caption = cap1.readLine
if err.number = 0 then
if Caption = "" then
Caption = cName
end if
else
Caption = cName
end if
if flg > 0 then
if flg = 2 then
Caption = "<h3>" & Caption & "</h3>"
end if
Body = cap1.ReadAll
if err.number = 0 then
if Body <> "" then
toHTML
end if
if flg = 1 then
Caption = Caption & "<br>" & Body
else
Caption = Caption & "<p>" & Body
end if
end if
end if
cap1.close()
else
Caption = cName
if flg = 2 then
Caption = "<h3>" & Caption & "</h3>"
end if
flag = false
end if
set cap1 = nothing
set FSO1 = nothing
set gifFile = nothing
end sub
sub getGifSize(cPath,cName,flg)
'flg = 0 return first line only
'flg = 1 return full text
'flg = 2 return full text with first line as header
on error resume next
dim FSO1
dim gifFile
Set FSO1 = CreateObject("Scripting.FileSystemObject")
set gifFile = FSO1.GetFile(cPath & "\" & cName & ".gif")
if err.number = 0 then
gifsize = gifFile.Size
end if
set FSO1 = nothing
set gifFile = nothing
end sub
Sub navTree(level, startLevel)
Dim Path
Dim Folders
dim SubFolders
Dim SubFolder
Dim Level1
Pass = startLevel
i = InStrRev(level,"\")
Path = mid(level,i+1)
FolderTitle = Path
i = InStrRev(Path,"\")
if i > 0 then
FolderTitle = mid(Path,i+1)
end if
Set FSO = CreateObject("Scripting.FileSystemObject")
set Folders=FSO.GetFolder(level)
Set SubFolders = Folders.SubFolders
getCaption level,FolderTitle,0
if Pass = 1 then
response.write "<ul>" & vbNewLine
Level1 = level
end if
Pass = Pass + 1
response.write "<li><A href="
response.write chr(34) & "default.asp?subPath=" & Server.URLEncode(level) & chr(34)
response.write ">" & Caption & "</A>" & vbNewLine
'Recursively check for subfolders
If SubFolders.Count > 0 Then
response.write "<ul>" & vbNewLine
For Each SubFolder In SubFolders
navTree SubFolder,Pass
next
response.write "</ul>" & vbNewLine
end if
set Folders = nothing
set SubFolders = nothing
set FSO = nothing
if Level1 = level then
response.write "</ul>" & vbNewLine
end if
End Sub
'Get Page Hit Count
'Table Name = Counter
'Table Fields = Sequence (Autonumber key), ID, Count
tbl = "Counter"
flag = "old"
'Note - Session variables could be used instead of cookies
VisitorCount = Request.Cookies(PageID)
If VisitorCount = "" then
Set conn=Server.CreateObject("ADODB.Connection")
conn.Open strconn
' Set rs = Server.CreateObject("ADODB.Recordset")
' rs.open tbl,conn,adOpenKeyset,adLockOptimistic
strSQL="Select Count from Counter where ID='" & PageID & "';"
Set rs=conn.Execute(strSQL)
if not rs.BOF then
VisitorCount = rs("Count")
flag = "old"
else
'This page has never been visited before
VisitorCount = 0
flag = "new"
end if
rs.Close
VisitorCount = VisitorCount + 1
Response.Cookies(PageID) = VisitorCount
if flag = "old" then
'Update the counter record
strSQL = "update " & tbl & " set Count=" & VisitorCount & " where ID='" & PageID & "';"
conn.execute(strSQL)
else
'Create a record for a page which is visited for the first time
rs.open tbl,conn,adOpenKeyset,adLockOptimistic
rs.AddNew
rs("ID") = PageID
rs("Count") = 1
rs.Update
end if
set rs = nothing
set conn = nothing
end if
Pass = 0
'Get graphic file information and create display tables
Sub GetFiles(Folder)
on error resume next
Dim Path
Dim Folders
dim SubFolders
Dim Files
Dim RootName
Dim gType
Dim Path_1
Dim Path_2
Dim SubFolder
Dim File
Dim cap
Dim pathT
'Get the relative path
Path = mid(Folder,i+1)
'Strip the path from the folder name for display purposes
'If you don't use HeaderTitle's names you might not want to do this
HeaderTitle = Path
i = InStrRev(Path,"\")
if i > 0 then
HeaderTitle = mid(Path,i+1)
end if
Set FSO = CreateObject("Scripting.FileSystemObject")
set Folders=FSO.GetFolder(Folder)
Set SubFolders = Folders.SubFolders
Set Files = Folders.Files
getCaption Folder,HeaderTitle,2
response.write "<hr size=5 width=" & chr(34) & "60%" & chr(34) & " align=" & chr(34) & "center" & chr(34) & "><p>" & vbNewLine
response.write Caption & "<p>" & vbNewLine
i = Files.Count
if Flag = true then i = i-1 end if 'Don't count the Caption file
If i > 0 Then
response.write "<table align=""center"">" & vbNewLine
response.write "<tr><th align=""center""><h4>Caption<br>Size</h4></th>" & vbNewLine
response.write "<th align=""center"" width=""200""><h4>Image</h4></th></tr>" & vbNewLine
For Each File In Files
'Get only gif and jpeg thumbnail files
'My thumbnails have "_t" at the end of the root file name
if UCase(Right(File.Name,6)) = "_T.JPG" then
RootName = Left(File.Name,Len(File.Name)-6)
response.write "<tr><td align=""center"">"
tmp = root & Path
getCaption tmp,RootName,1
response.write Caption
response.write "<br>" & File.Size & " bytes</td>" & vbNewLine
response.write "<td align=""center"">"
response.write "<a href=" & chr(34) & path & "/" & rootname & ".jpg" & chr(34)
response.write " target="& chr(34) & rootname & chr(34)
response.write ">" & vbNewLine
response.write "<img src=" & chr(34) & Path & "\" & RootName & "_t" & ".jpg" & chr(34)
response.write " alt=" & chr(34) & RootName & " Thumbnail" & chr(34) & ">"
response.write "</a>"
response.write "</td></tr>" & vbNewLine
end if
Next
response.write "</table>" & vbNewLine
'Print a bottom bar
response.Write "<p><hr size=5 width=" & chr(34) & "60%" & chr(34) & " align=" & chr(34) & "center" & chr(34) & ">" & vbNewLine
Pass = 0
if not (HeaderTitle=topLevel) then
response.write "<FORM ACTION="
response.write chr(34) & "default.asp" & chr(34)
response.write " METHOD=POST>" & vbNewLine
response.write "<input name=" & chr(34) & "submit" & chr(34)
response.write " type=submit value=" & chr(34) & "Go to Top Level" & chr(34) & ">" & vbNewLine
response.write "</form>" & vbNewLine
end if
Else
response.Write "<p>There are no photographs at this location." & vbNewLine
response.write "<hr size=5 width=" & chr(34) & "60%" & chr(34) & " align=" & chr(34) & "center" & chr(34) & ">" & vbNewLine
End If
'Recursively check for subfolders
If SubFolders.Count > 0 Then
For Each SubFolder In SubFolders
FolderTitle = SubFolder
i = InStrRev(SubFolder,"\")
if i > 0 then
FolderTitle = mid(SubFolder,i+1)
end if
getCaption subFolder,FolderTitle,0
response.write "<FORM ACTION="
response.write chr(34) & "default.asp?subPath="& Server.URLEncode(SubFolder) & chr(34)
response.write " METHOD=POST>" & vbNewLine
response.write "<input name=" & chr(34) & "submit" & chr(34)
response.write " type=submit value=" & chr(34) & Caption & chr(34) & ">" & vbNewLine
response.write "</form>" & vbNewLine
next
end if
response.write "<hr size=5 width=" & chr(34) & "60%" & chr(34) & " align=" & chr(34) & "center" & chr(34) & ">" & vbNewLine
set Folders = nothing
set FSO = nothing
End Sub
%>
<html>
<head>
<LINK rel="stylesheet" type="text/css" href="loopers.css">
<title>Martin Loopers' Photo Gallery</title>
</head>
<body>
<center>
<TABLE>
<tr>
<td><IMG SRC="images/LuthersRose.gif" ALIGN=Left ALT="Luther's Rose"
WIDTH=256 HEIGHT=261 hspace=0 vspace=0></td>
<td width=10%> </td>
<td align="center"><h1>MartinLoopers</h1><p>
<h2>Photo Gallery</h2></td>
</tr>
</TABLE>
<p>
<hr size=5 width=60% align=center><h3 align=center>Who are we?</h3><p>
MartinLoopers is an email list for Lutheran Homeschooling families.
For information on subscription options, how to unsubscribe, or how to
contact the list administrator, send a note to
<a name=mail href="Mailto:Requests@CAT41.org?subject=info martinloopers" title="Send email to the discussion list administrator.">
<em>Requests@CAT41.org</em></a>,
with the subject line or body reading: <em>info martinloopers</em>.
<p>
<hr size=5 width=60% align=center>
<p>
Click the thumbnail for a larger Jpeg image.
<br>
The photographs will appear in another window.
<p>
<%
'Pass the name of the subfolder containing the photographs to the subroutine
getfiles subPath
%>
<p>
<h3>Notes</h3>
<p>
The respective Photographers retain the copyright to all images on or linked to this page.
<p>
<hr size=5 width=60% align=center>
<p>
<%
'Place information which is to be only on the top level page in the section below
if HeaderTitle=topLevel then
%>
<table align=center width=50%><tr><td align=center>
<h3>Links</h3></td></tr>
<tr><td align=center>
<A HREF="http://www.cat41.org/loopers">The MartinLoopers' Web Site</A></td></tr>
<tr><td align=center>
<A HREF="http://www.lcms.org">Lutheran Church - Missouri Synod</A></td></tr>
<tr><td align=center>
<a href="http://www.lhm.org/">Lutheran Hour Ministries</a><br>
<A HREF="http://www.iclnet.org/pub/resources/text/wittenberg/wittenberg-home.html">
Project Wittenberg</A></td></tr>
<tr><td align=center>
<A HREF="http://www.gospelcom.net/bible">The WWW Bible Gateway</A></td></tr>
<tr><td align=center>
<A HREF="http://www.lutheran-hymnal.com/">The Lutheran-Hymnal.Com</A></td></tr>
</table>
<p>
<hr size=5 width=60% align=center>
<%
end if
'End of Top Levle Only section
%>
<p>
This is a self maintaining site.
<br>
Each time this page is accessed it checks for
all available photographs and sub-folders.<br>
Sub-folders are represented by navigation buttons which will take you to that location.
<p>
If you are interested in the actual code that produced the MartinLoopers
Photo Gallery you can see it here.
<br>
<A href="displayasp.asp?file=default.asp&app=MartinLoopers">Active Server Page which creates the Photo Gallery</a><br>
<A href="displayasp.asp?file=loopers.css&app=MartinLoopers">Cascading Style Sheet</a><br>
<p>
This site was created on May 14, 1999 and this page has been accessed
<% =VisitorCount %>
times since 08/01/2000.<br>
<p>
If you have any problems or suggestions about this site please let me know.<br>
<a name=me href="Mailto:allen@amulvey.com?subject='MartinLoopers Webmaster'" title="Send email to Allen Mulvey.">
Allen Mulvey</a><br>
</center>
</body>
</html>