<%@ 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

Links: [2010 Reunion Info]  [2005 Reunion Photos]  [Main BBS]  [Ray Crew List]  [SubmarineSailor.Com

Welcome to the USS Ray BBS

<% 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() %>

Search the forums for a keyword:
<% 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 ======================================================= %>