<%@ 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 ================================================================
%>
<%
ProcessForumPage True
Dim objMiscRS
%>
<%
'== BEGIN MAIN =================================================================
Sub Main()
Dim objForumRS, objMessageRS
Dim objForumCountRS, objMessageCountRS
Dim strThreadList
Dim iActiveForumId, iActiveForumName
Dim iForumMessageCount
Dim iPeriodLooper
Dim iPeriodToShow
Dim iPeriodsToGoBack
Dim strForumBreakdownType
Dim dStartDate
Dim dEndDate
iActiveForumId = Request.QueryString("fid")
If IsNumeric(iActiveForumId) Then
iActiveForumId = CInt(iActiveForumId)
Else
iActiveForumId = 0
End If
iPeriodToShow = Request.QueryString("pts")
If IsNumeric(iPeriodToShow) Then
iPeriodToShow = CInt(iPeriodToShow)
Else
iPeriodToShow = 0
End If
' Get Forum Info and count of messages in the forum
Set objForumRS = GetRecordset("SELECT * FROM forums;")
Set objForumCountRS = GetRecordset("SELECT forum_id, COUNT(*) FROM messages GROUP BY forum_id;")
If Not objForumRS.EOF Then
objForumRS.MoveFirst
Do While Not objForumRS.EOF
' Set to default from script constant
strForumBreakdownType = MESSAGE_GROUPING
' Check DB for a value to override
If objForumRS.Fields.Count >= 5 Then
If objForumRS.Fields(4).Name = "forum_grouping" Then
strForumBreakdownType = Trim(LCase(objForumRS.Fields("forum_grouping").Value))
End If
End If
'Response.Write strForumBreakdownType
' Position Forum Count RS and get a message count
' Thought this would be faster, but it wasn't!
'objForumCountRS.Filter = "forum_id = " & objForumRS.Fields("forum_id")
objForumCountRS.MoveFirst
Do Until objForumCountRS.EOF
If objForumCountRS.Fields("forum_id") = objForumRS.Fields("forum_id") Then Exit Do
objForumCountRS.MoveNext
Loop
If Not objForumCountRS.EOF Then
iForumMessageCount = objForumCountRS.Fields(1)
Else
iForumMessageCount = 0
End If
' If active forum -> show messages o/w just show forum
If objForumRS.Fields("forum_id") = iActiveForumId Then
iActiveForumName = objForumRS.Fields("forum_name")
If iActiveForumId <> 0 Then
%>
Post
a New Message to:
<%= iActiveForumName %>
<%
End If
ShowForumLine objForumRS.Fields("forum_id"), "open", objForumRS.Fields("forum_name"), objForumRS.Fields("forum_description"), iForumMessageCount
' Show links to previous months
iPeriodsToGoBack = DateDiff("m", objForumRS("forum_start_date"), Now())
' Make adjustments to periods to go back and show for non-monthly breakdown
Select Case strForumBreakdownType
Case "7days"
iPeriodsToGoBack = iPeriodsToGoBack + 3
Case "monthly"
' Nothing to do!
Case Else
iPeriodsToGoBack = 0
iPeriodToShow = 0
End Select
For iPeriodLooper = 0 To iPeriodsToGoBack
If strForumBreakdownType = "7days" Or strForumBreakdownType = "monthly" Then
'Do period message count here.
ShowPeriodLine objForumRS.Fields("forum_id"), strForumBreakdownType, iPeriodLooper, 0
End If
If iPeriodLooper = iPeriodToShow Then
'Show Root Level Posts for the selected period and their reply count
Select Case strForumBreakdownType
Case "7days"
If iPeriodToShow <= 2 Then
dStartDate = Date() - (7 * (iPeriodToShow + 1)) + 1
dEndDate = Date() - (7 * iPeriodToShow) + 1
Else
dStartDate = GetNMonthsAgo(iPeriodToShow - 3)
dEndDate = GetNMonthsAgo(iPeriodToShow - 4)
End If
Case "monthly"
dStartDate = GetNMonthsAgo(iPeriodToShow)
dEndDate = GetNMonthsAgo(iPeriodToShow - 1)
Case Else
dStartDate = objForumRS.Fields("forum_start_date").Value
dEndDate = Date() + 1
End Select
'Response.Write dStartDate & " "
'Response.Write dEndDate & " "
Set objMessageRS = GetRecordset("SELECT * FROM messages WHERE forum_id=" & iActiveForumId & " AND thread_parent=0 AND " & DB_DATE_DELIMITER & FormatTimestampDB(dStartDate) & DB_DATE_DELIMITER & " < message_timestamp AND message_timestamp < " & DB_DATE_DELIMITER & FormatTimestampDB(dEndDate) & DB_DATE_DELIMITER & " ORDER BY thread_id DESC;")
objMessageRS.CacheSize = 100
' Build the list of root posts we need counts for
If Not (objMessageRS.BOF And objMessageRS.EOF) Then
objMessageRS.MoveFirst
Do While Not objMessageRS.EOF
strThreadList = strThreadList & objMessageRS("thread_id") & ","
objMessageRS.MoveNext
Loop
strThreadList = Left(strThreadList, Len(strThreadList) - 1)
Else
strThreadList = (0)
End If
Set objMessageCountRS = GetRecordset("SELECT thread_id, COUNT(*) FROM messages WHERE thread_id IN (" & strThreadList & ") GROUP BY thread_id ORDER BY thread_id DESC;")
objMessageCountRS.CacheSize = 100
' We don't worry about a zero count because every thread should have at least 1 message
' Along the same lines, objMessageRS.RecordCount needs to equal objMessageCountRS.RecordCount
' We assume they do. If not we're in deep sh*t! Please never break! I'm, begging here!
'Response.Write objMessageRS.RecordCount & " " & vbCrLf
'Response.Write objMessageCountRS.RecordCount & " " & vbCrLf
' Oh what the heck, even if it does break it's only the message count and not checking each record gives us a HUGE SPEED BOOST...
' Screw it, here goes...
If Not (objMessageRS.BOF And objMessageRS.EOF) Then
objMessageRS.MoveFirst
objMessageCountRS.MoveFirst
Do While Not objMessageRS.EOF
'ShowMessageLine 1, objMessageRS.Fields("message_id"), objMessageRS.Fields("message_subject"), objMessageRS.Fields("message_author"), objMessageRS.Fields("message_author_email"), FormatTimestampDisplay(objMessageRS.Fields("message_timestamp")), objMessageCountRS.Fields(1) - 1, "forum", 0
'===============new stuff to show all messages =================
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, 2, iActiveMessageId
'ShowChildren 0, 0, 2, objMessageRS.Fields("message_id")
ShowChildren 0, 0, 1, request.QueryString("mid")
objMiscRS.Close
Set objMiscRS = Nothing
'-=========================================================================
objMessageRS.MoveNext
objMessageCountRS.MoveNext
Loop
End If
'Close Message DB objects
objMessageCountRS.Close
Set objMessageCountRS = Nothing
objMessageRS.Close
Set objMessageRS = Nothing
End If
Next 'iPeriodLooper
'Set active Forum Name for later use in post line
iActiveForumName = objForumRS.Fields("forum_name")
Else
ShowForumLine objForumRS.Fields("forum_id"), "closed", objForumRS.Fields("forum_name"), objForumRS.Fields("forum_description"), iForumMessageCount
End If
objForumRS.MoveNext
Loop
Else
WriteLine "There are no folders currently open." & " "
End If
'Close Forum DB objects
objForumCountRS.Close
Set objForumCountRS = Nothing
objForumRS.Close
Set objForumRS = Nothing
If iActiveForumId <> 0 Then
%>
Post
a New Message to:
<%= iActiveForumName %>
<%
End If
ShowSearchForm
End Sub ' Main
'== END MAIN ===================================================================
'== BEGIN SUBS & FUNCTIONS =====================================================
Function GetNMonthsAgo(iMonthsAgo)
Dim dPastDate
dPastDate = Date()
'Response.Write dPastDate & " "
dPastDate = DateAdd("m", -iMonthsAgo, dPastDate)
'Response.Write dPastDate & " "
dPastDate = DateAdd("d", -(Day(dPastDate) - 1), dPastDate)
'Response.Write dPastDate & " "
GetNMonthsAgo = CDate(dPastDate)
End Function ' GetNMonthsAgo
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 =======================================================
%>
