<%@ Language = "VBScript" %>
<%
Option Explicit
Response.Buffer = True
' You may need to kill the above 3 setting based on your include situation, but
' if this code is used as is they should work fine.
' Our include files. A trimmer version of adovbs.inc and our config file.
%>
<%
'--------------------------------------------------------------------
' Microsoft ADO
' Copyright (c) 1996-1998 Microsoft Corporation.
'
' ADO constants include file for VBScript
'
' modified by john@asp101.com to remove unused constants
'--------------------------------------------------------------------
'---- CursorTypeEnum Values ----
Const adOpenForwardOnly = 0
Const adOpenKeyset = 1
Const adOpenDynamic = 2
Const adOpenStatic = 3
'---- LockTypeEnum Values ----
Const adLockReadOnly = 1
Const adLockPessimistic = 2
Const adLockOptimistic = 3
Const adLockBatchOptimistic = 4
'---- CursorLocationEnum Values ----
Const adUseServer = 2
Const adUseClient = 3
'---- CommandTypeEnum Values ----
Const adCmdUnknown = &H0008
Const adCmdText = &H0001
Const adCmdTable = &H0002
Const adCmdStoredProc = &H0004
Const adCmdFile = &H0100
Const adCmdTableDirect = &H0200
'Added by jeremy@gexweb.net for admin area
Const adExecuteNoRecords = &H00000080
Const adAffectCurrent = 1
%>
<%
'== BEGIN CONSTANTS ============================================================
' I'm going to use some fake Consts here just to make my life easier.
' I do this because I have an application var that stores site wide
' DB connection info, username, and password. As constants I'd have
' to truly hard code them and I also couldn't do the Server.MapPath
' for Access. After these few lines however, they are treated
' STRICTLY as if they were true Consts and are not modified in any
' other place!
Dim DB_CONNECTIONSTRING, DB_USERNAME, DB_PASSWORD
Dim DB_DATE_DELIMITER
' Default Access DB connection info
'DB_CONNECTIONSTRING = "Provider=Microsoft.Jet.OLEDB.3.51; Data Source=" & Server.MapPath("database/raybbs.mdb") & ";"
' Some alternate drivers. I've tested against all 3 of these.
'DB_CONNECTIONSTRING = "DRIVER={Microsoft Access Driver (*.mdb)}; DBQ=" & Server.Mappath("database/raybbs.mdb") & ";"
DB_CONNECTIONSTRING = "Provider=Microsoft.Jet.OLEDB.4.0; Data Source=" & Server.MapPath("database/raybbs.mdb") & ";"
DB_USERNAME = ""
DB_PASSWORD = ""
' Sample SQL Server connection info
'DB_CONNECTIONSTRING = "Provider=SQLOLEDB; Data Source=sql_server_name_or_ip; Initial Catalog=db_name;"
'DB_USERNAME = "user"
'DB_PASSWORD = "pass"
' Date delimiter: Access likes # / SQL likes '
DB_DATE_DELIMITER = "#"
' Automatically enables / disables sending of e-mail and all related functions
' If you turn this on be sure you configure the SendEmail function
' below to use your component as well as
' CHANGE THE MESSAGE AND ADDRESSES!
Const SEND_EMAIL = False
' In new verions this should be set in the forums table. This constant
' is used to determine the grouping if that field doesn't exist.
Const MESSAGE_GROUPING = "" ' "monthly" / "7days" / ""
'== END CONSTANTS ==============================================================
'== BEGIN SUBS & FUNCTIONS =====================================================
Sub ShowHeader()
%>
USS Ray BBS on SubmarineSailor.com
<%
End Sub
Sub ShowFooter()
%>
<%
End Sub
' You'll need to modify this function to use whatever email compnent
' you prefer if you want to use email notification.
Sub SendEmail(strFrom, strTo, strSubject, strBody)
' DB and email object vars for email notification
Dim objCDOMail
' Make sure emailing is enabled
If SEND_EMAIL Then
' Create an instance of the NewMail object.
Set objCDOMail = Server.CreateObject("CDONTS.NewMail")
' Set the properties of the object
objCDOMail.From = strFrom
objCDOMail.To = strTo
objCDOMail.Subject = strSubject
objCDOMail.Body = strBody
' Send the message!
objCDOMail.Send
Set objCDOMail = Nothing
End If
End Sub ' SendEmail
'== END SUBS & FUNCTIONS =======================================================
%>
<%
' GLOBAL VAR!!!
Dim cnnForumDC ' Our Data Connection used throughout
'== BEGIN PROCESSOR ============================================================
' This is the processing controller for all pages!
Sub ProcessForumPage(bOpenConnection)
' Speed timer for testing - see bottom of function as well
'Dim PageSpeedTimer
'PageSpeedTimer = Timer()
' Show the pre-forum HTML
Call ShowHeader
' If a Data Connection is requested then provide one
If bOpenConnection Then
Set cnnForumDC = Server.CreateObject("ADODB.Connection")
cnnForumDC.CommandTimeout = 30
cnnForumDC.ConnectionTimeout = 20
cnnForumDC.Open DB_CONNECTIONSTRING, DB_USERNAME, DB_PASSWORD
End If
Call Main
' If a Data Connection was used then tear it down
If bOpenConnection Then
cnnForumDC.Close
Set cnnForumDC = Nothing
End If
' Show the post-forum HTML
Call ShowFooter
' Speed timer for testing - see top of function as well
'Response.Write "
" & Response.Buffer & " "
'Response.Write Timer() - PageSpeedTimer
If Response.Buffer Then Response.Flush
End Sub
'== END PROCESSOR ==============================================================
'== BEGIN UTILITIES ============================================================
Sub WriteLine(strText)
Response.Write strText & vbCrLf
End Sub
Function Lineify(strInput)
Dim strTemp
strTemp = Server.HTMLEncode(strInput)
strTemp = Replace(strTemp, " ", " ", 1, -1, 1)
strTemp = Replace(strTemp, " ", " ", 1, -1, 1)
strTemp = Replace(strTemp, " ", " ", 1, -1, 1)
strTemp = Replace(strTemp, " ", " ", 1, -1, 1)
strTemp = Replace(strTemp, " ", " ", 1, -1, 1)
strTemp = Replace(strTemp, vbTab, " ", 1, -1, 1)
strTemp = Replace(strTemp, vbCrLf, " " & vbCrLf, 1, -1, 1)
Lineify = strTemp
End Function
Function LineifyHTML(strInput)
Dim strTemp
strTemp = strInput
strTemp = Replace(strTemp, " ", " ", 1, -1, 1)
strTemp = Replace(strTemp, " ", " ", 1, -1, 1)
strTemp = Replace(strTemp, " ", " ", 1, -1, 1)
strTemp = Replace(strTemp, " ", " ", 1, -1, 1)
strTemp = Replace(strTemp, " ", " ", 1, -1, 1)
strTemp = Replace(strTemp, vbTab, " ", 1, -1, 1)
strTemp = Replace(strTemp, vbCrLf, " " & vbCrLf, 1, -1, 1)
LineifyHTML = strTemp
End Function
Function FormatTimestampDB(dTimestampToFormat)
' Formats to "m/d/yyyy h:mm:ss AM" format
' Change as appropriate to match your DB
Dim strMonth, strDay, strYear
Dim strHour, strMinute, strSecond
Dim strAMPM
strMonth = Month(dTimestampToFormat)
strDay = Day(dTimestampToFormat)
strYear = Year(dTimestampToFormat)
'strYear = Right(Year(dTimestampToFormat), 2)
strHour = Hour(dTimestampToFormat) Mod 12
If strHour = 0 Then strHour = 12
If Hour(dTimestampToFormat) < 12 Then
strAMPM = "AM"
Else
strAMPM = "PM"
End If
strMinute = Minute(dTimestampToFormat)
If Len(strMinute) = 1 Then strMinute = "0" & strMinute
strSecond = Second(dTimestampToFormat)
If Len(strSecond) = 1 Then strSecond = "0" & strSecond
' "d/m/yyyy h:mm:ss AM" for all those who have had problems.
'FormatTimestampDB = strDay & "/" & strMonth & "/" & strYear & " " & strHour & ":" & strMinute & ":" & strSecond & " " & strAMPM
FormatTimestampDB = strMonth & "/" & strDay & "/" & strYear & " " & strHour & ":" & strMinute & ":" & strSecond & " " & strAMPM
End Function
Function FormatTimestampDisplay(dTimestampToFormat)
' Formats to "m/d/yyyy h:mm:ss AM" format
' Change as appropriate to match your display wishes
Dim strMonth, strDay, strYear
Dim strHour, strMinute, strSecond
Dim strAMPM
strMonth = Month(dTimestampToFormat)
strDay = Day(dTimestampToFormat)
strYear = Year(dTimestampToFormat)
'strYear = Right(Year(dTimestampToFormat), 2)
strHour = Hour(dTimestampToFormat) Mod 12
If strHour = 0 Then strHour = 12
If Hour(dTimestampToFormat) < 12 Then
strAMPM = "AM"
Else
strAMPM = "PM"
End If
strMinute = Minute(dTimestampToFormat)
If Len(strMinute) = 1 Then strMinute = "0" & strMinute
strSecond = Second(dTimestampToFormat)
If Len(strSecond) = 1 Then strSecond = "0" & strSecond
' "d/m/yyyy h:mm:ss AM" for all those who have had problems.
'FormatTimestampDB = strDay & "/" & strMonth & "/" & strYear & " " & strHour & ":" & strMinute & ":" & strSecond & " " & strAMPM
FormatTimestampDisplay = strMonth & "/" & strDay & "/" & strYear & " " & strHour & ":" & strMinute & ":" & strSecond & " " & strAMPM
End Function
'== END UTILITIES ==============================================================
'== BEGIN DATABASE =============================================================
Function GetRecordset(sRSSource)
Dim objRSGetRecordset
Set objRSGetRecordset = Server.CreateObject("ADODB.RecordSet")
objRSGetRecordset.Open sRSSource, cnnForumDC, adOpenStatic, adLockReadOnly
Set GetRecordset = objRSGetRecordset
'objRSGetRecordset.Close
Set objRSGetRecordset = Nothing
End Function
'== END DATABASE ===============================================================
'== BEGIN DISPLAY ==============================================================
Sub ShowForumLine(iId, sFolderStatus, sName, sDescription, iMessageCount)
Dim strOutput
strOutput = " "
strOutput = strOutput & " "
strOutput = strOutput & "" & sName & ""
strOutput = strOutput & " -- "
strOutput = strOutput & sDescription
If iMessageCount <> 0 Then
strOutput = strOutput & " ("
strOutput = strOutput & iMessageCount
strOutput = strOutput & " messages)"
End If
WriteLine strOutput & " "
End Sub
Sub ShowPeriodLine(iForumId, strPeriodType, iPeriodsAgo, iMessageCount)
Dim strOutput
strOutput = strOutput & " "
strOutput = strOutput & ""
strOutput = strOutput & ""
If strPeriodType = "7days" Then
Select Case iPeriodsAgo
Case 0
strOutput = strOutput & "Last 7 Days"
Case 1
strOutput = strOutput & "8 to 14 Days Ago"
Case 2
strOutput = strOutput & "15 to 21 Days Ago"
Case Else
strOutput = strOutput & "" & MonthName(Month(DateAdd("m", -(iPeriodsAgo - 3), Date()))) & "'s Posts"
End Select
Else
strOutput = strOutput & "" & MonthName(Month(DateAdd("m", -iPeriodsAgo, Date()))) & "'s Posts"
End If
If iMessageCount <> 0 Then
strOutput = strOutput & " ("
strOutput = strOutput & iMessageCount
strOutput = strOutput & " messages)"
End If
WriteLine strOutput & " "
End Sub
Sub ShowMessageLine(iDepth, iId, sSubject, sAuthor, sEmail, sTime, iReplyCount, sPageType, iActiveMessageId)
Dim strOutput
Dim I
strOutput = ""
For I = 0 to iDepth - 1
if iDepth = 1 then
strOutput = strOutput & "
"
else
strOutput = strOutput & ""
end if
Next 'I
If sPageType = "message" Then
If iActiveMessageId = iId Then
strOutput = strOutput & ""
Else
strOutput = strOutput & ""
End If
Else
strOutput = strOutput & ""
End If
if iDepth = 1 then
strOutput = strOutput & ""
else
strOutput = strOutput & ""
end if
strOutput = strOutput & " "
strOutput = strOutput & "" & Replace(Server.HTMLEncode(sSubject), " ", " ", 1, -1, 1) & ""
strOutput = strOutput & " by "
strOutput = strOutput & "" & Replace(Server.HTMLEncode(sAuthor), " ", " ", 1, -1, 1) & ""
If sPageType = "message" And sEmail <> "" Then
strOutput = strOutput & " "
End If
strOutput = strOutput & " at "
strOutput = strOutput & Replace(sTime, " ", " ", 1, -1, 1)
If sPageType = "forum" Then
strOutput = strOutput & " ("
if iReplyCount <> 0 then
strOutput = strOutput & "" & iReplyCount & ""
else
strOutput = strOutput & iReplyCount
end if
strOutput = strOutput & " replies)"
End If
strOutput = strOutput & ""
WriteLine strOutput & " "
End Sub
Sub ShowSearchForm()
%>
<%
End Sub
'== END DISPLAY ================================================================
%>
<%
' This needs to be global for the recursive function
Dim objMiscRS
ProcessForumPage True
%>
<%
'== BEGIN MAIN =================================================================
Sub Main()
Dim iActiveMessageId
Dim iActiveForumId
Dim objMessageRS
'Dim objMiscRS
iActiveMessageId = Request.QueryString("mid")
If IsNumeric(iActiveMessageId) Then
iActiveMessageId = CInt(iActiveMessageId)
Else
iActiveMessageId = 0
End If
Set objMessageRS = GetRecordset("SELECT * FROM messages WHERE message_id=" & iActiveMessageId & ";")
If Not objMessageRS.EOF Then
objMessageRS.MoveFirst
'For I = 0 to objMessageRS.Fields.Count - 1
' WriteLine objMessageRS.Fields(I).Name & ": "
' WriteLine objMessageRS.Fields(I) & " "
'Next
iActiveForumId = objMessageRS.Fields("forum_id")
%>
Author:
<%= objMessageRS.Fields("message_author") %>
E-mail:
<% If IsNull(objMessageRS.Fields("message_author_email")) Then %>
Other Messages in This Thread:
<%
Set objMiscRS = GetRecordset("SELECT * FROM forums WHERE forum_id=" & iActiveForumId & ";")
If Not objMiscRS.EOF Then
objMiscRS.MoveFirst
'ShowForumLine objMiscRS.Fields("forum_id"), "open", objMiscRS.Fields("forum_name"), objMiscRS.Fields("forum_description"), 0
End If
objMiscRS.Close
Set objMiscRS = Nothing
Set objMiscRS = Server.CreateObject("ADODB.RecordSet")
objMiscRS.CursorLocation = adUseClient
objMiscRS.ActiveConnection = cnnForumDC
objMiscRS.CursorType = adOpenStatic
objMiscRS.LockType = adLockReadOnly
objMiscRS.Open "SELECT * FROM messages WHERE thread_id=" & objMessageRS.Fields("thread_id").Value & " ORDER BY thread_parent;"
objMiscRS.ActiveConnection = Nothing
ShowChildren 0, 0, 0, iActiveMessageId
objMiscRS.Close
Set objMiscRS = Nothing
Else
WriteLine "Unable to locate that message!" & " "
End If
objMessageRS.Close
Set objMessageRS = Nothing
End Sub 'Main
'== END MAIN ===================================================================
'== BEGIN SUBS & FUNCTIONS =====================================================
Sub ShowChildren(iParentId, iPreviousFilter, iCurrentLevel, iActiveMessageId)
Dim iCurrentLocation
objMiscRS.Filter = "thread_parent = " & iParentId
If objMiscRS.RecordCount <> 0 Then
If Not objMiscRS.BOF Then objMiscRS.MoveFirst
Do While Not objMiscRS.EOF
ShowMessageLine iCurrentLevel, objMiscRS.Fields("message_id"), objMiscRS.Fields("message_subject"), objMiscRS.Fields("message_author"), objMiscRS.Fields("message_author_email"), FormatTimestampDisplay(objMiscRS.Fields("message_timestamp")), 0, "message", iActiveMessageId
iCurrentLocation = objMiscRS.AbsolutePosition
'Response.Write iCurrentLocation
ShowChildren objMiscRS.Fields("message_id").Value, objMiscRS.Filter, iCurrentLevel + 1, iActiveMessageId
'Response.Write iCurrentLocation
objMiscRS.AbsolutePosition = iCurrentLocation
objMiscRS.MoveNext
Loop
End If
objMiscRS.Filter = iPreviousFilter
End Sub ' ShowChildren
'== END SUBS & FUNCTIONS =======================================================
%>
