<%@ 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
%>
<%
'== BEGIN MAIN =================================================================
Sub Main()
' Message parameters
Dim iForumId, iThreadId, iThreadParent, iThreadLevel
Dim sSubject, sMessage, bNotify, sLink, sLinkTitle, sImageLink
Dim sName, sEmail ' User Info from Cookies
Dim iNewMessageId ' Id of the message we're adding
Select Case Request.QueryString("action")
Case "save"
' Retrieve parameters
iForumId = Request.Form("forum_id")
iThreadId = Request.Form("thread_id")
iThreadParent = Request.Form("thread_parent")
iThreadLevel = Request.Form("thread_level")
sName = Request.Form("name")
sEmail = Request.Form("email")
sSubject = Request.Form("subject")
sMessage = Request.Form("message")
bNotify = Request.Form("notify")
sLink = Request.Form("link")
sLinkTitle = Request.Form("link_title")
sImageLink = request.Form("image_link")
If bNotify = "yes" Then
bNotify = True
Else
bNotify = False
End If
' Validate Input
If InputIsValid("save", iForumId, iThreadId, iThreadParent, iThreadLevel, sName, sSubject, sMessage, sEmail, sLink, sLinkTitle, sImageLink) Then
' check for known spam addresses
If right(sEmail,12) <> "cashette.com" _
and right(sEmail,3) <> ".ru" _
and left(sEmail,5) <> "burug" _
and left(sEmail,5) <> "kubsk" _
and left(sEmail,4) <> "kubi" _
and right(sEmail,9) <> "@mail.com" _
and left(sEmail,9) <> "mylo@soap" _
and left(sEmail,6) <> "nurse_" _
and left(sEmail,9) <> "anonymous" _
and left(sSubject,4) <> "Grom" _
and left(sEmail,9) <> "ihatespam" _
and InStr(1,sMessage,"[URL=http",1) = 0 _
and left(sEmail,3) = "653" _
and right(sEmail,3) = "653" _
then
' Insert the New Message
iNewMessageId = InsertRecord(iForumId, iThreadId, iThreadParent, iThreadLevel, sName, sEmail, bNotify, sSubject, sMessage, sLink, sLinkTitle, sImageLink)
' Show The Thanks Page
ShowThanks iNewMessageId, iThreadParent, iForumId, sName, sEmail
' Send Email Notification
SendEmailNotification iNewMessageId, iThreadId, sEmail
End If
Else
ShowForm iForumId, iThreadId, iThreadParent, iThreadLevel, sName, sEmail, sSubject, sMessage, sLink, sLinkTitle, sImageLink
End If
Case Else
' Retrieve Parameters
iForumId = Request.QueryString("fid")
iThreadId = Request.QueryString("tid")
iThreadParent = Request.QueryString("pid")
iThreadLevel = Request.QueryString("level")
sName = Request.Cookies("name")
sEmail = Request.Cookies("email")
sSubject = Request.QueryString("subject")
'sMessage = Request.Form("message")
If Len(sSubject) <> 0 And Left(sSubject, 3) <> "Re:" Then
If Len(sSubject) > 46 Then ' If Re: won't fit!
sSubject = "Re: " & Left(sSubject, 43) & "..."
Else
sSubject = "Re: " & sSubject
End If
End If
If InputIsValid("post", iForumId, iThreadId, iThreadParent, iThreadLevel, sName, sSubject, sMessage, sEmail, sLink, sLinkTitle, sImageLink) Then
ShowForm iForumId, iThreadId, iThreadParent, iThreadLevel, sName, sEmail, sSubject, sMessage, sLink, sLinkTitle, sImageLink
Else
' A message should have been displayed by the validation routine so we do nothing!
End If
End Select
End Sub 'Main
'== END MAIN ===================================================================
%>
<%
'== BEGIN SUBS & FUNCTIONS =====================================================
Function InputIsValid(strSituation, iForumId, iThreadId, iThreadParent, iThreadLevel, sName, sSubject, sMessage, sEmail, sLink, sLinkTitle, sImageLink)
Dim bEverythingIsCool
bEverythingIsCool = True
'Validate info
If IsNumeric(iForumId) Then
If iForumId <> 0 Then
iForumId = CLng(iForumId)
Else
WriteLine "You aren't in an active forum! "
bEverythingIsCool = False
End If
Else
WriteLine "You aren't in an active forum! "
bEverythingIsCool = False
End If
If IsNumeric(iThreadId) And IsNumeric(iThreadParent) And IsNumeric(iThreadLevel) Then
iThreadId = CLng(iThreadId)
iThreadParent = CLng(iThreadParent)
If iThreadLevel = 0 Then iThreadLevel = 1
iThreadLevel = CLng(iThreadLevel)
Else
WriteLine "Invalid thread information! "
bEverythingIsCool = False
End If
' Do our additional checks if we're about to save!
If strSituation = "save" Then
If Len(sName) = 0 Then
WriteLine "Name can't be empty! "
bEverythingIsCool = False
End If
If Len(sSubject) = 0 Then
WriteLine "Subject can't be empty! "
bEverythingIsCool = False
End If
If Len(sEmail) = 0 Then
WriteLine "Please include your email address! "
bEverythingIsCool = False
End If
If Len(sMessage) = 0 Then
WriteLine "Message can't be empty! "
bEverythingIsCool = False
End If
if Len(sLink) <> 0 then
if lCase(mid(sLink,1,7)) <> "http://" then
WriteLine "ERROR: Links must begin with 'http://' "
bEverythingIsCool = False
end if
end if
if Len(sImageLink) <> 0 then
if lCase(mid(sImageLink,1,7)) <> "http://" then
WriteLine "ERROR: Image links must begin with 'http://' "
bEverythingIsCool = False
end if
end if
End If
InputIsValid = bEverythingIsCool
End Function ' InputIsValid
Sub ShowForm(forum_id, thread_id, thread_parent, thread_level, name, email, subject, message, link, link_title, image_link)
%>
<% If thread_parent <> 0 Then %>
Back
to previous Message
<% End If %>
Back to the
Main Board
<%
End Sub ' ShowForm
Function InsertRecord(forum_id, thread_id, thread_parent, thread_level, author, email, notify, subject, body, link, link_title, image_link)
Dim objRSInsert
Dim dTimeStamp
Dim iNewMessageId
dTimeStamp = Now()
Set objRSInsert = Server.CreateObject("ADODB.RecordSet")
' Access likes #'s, SQL doesn't
objRSInsert.Open "SELECT * FROM messages WHERE message_timestamp=" & DB_DATE_DELIMITER & FormatTimestampDB(dTimeStamp) & DB_DATE_DELIMITER & ";", cnnForumDC, adOpenDynamic, adLockPessimistic
objRSInsert.AddNew
objRSInsert.Fields("message_timestamp") = dTimeStamp
objRSInsert.Fields("forum_id") = forum_id
objRSInsert.Fields("thread_id") = thread_id
objRSInsert.Fields("thread_parent") = thread_parent
objRSInsert.Fields("thread_level") = thread_level
objRSInsert.Fields("message_author") = author
If email <> "" Then objRSInsert.Fields("message_author_email") = email
objRSInsert.Fields("message_author_notify") = notify
objRSInsert.Fields("message_subject") = subject
objRSInsert.Fields("message_body") = body
objRSInsert.Fields("link") = link
objRSInsert.Fields("link_title") = link_title
objRSInsert.Fields("image_link") = image_link
objRSInsert.Update
' Doesn't work with Access!
'objRSInsert.Fields("thread_id") = objRSInsert.Fields("message_id")
'objRSInsert.Update
objRSInsert.Requery ' To be sure we have the message_id back from the DB.
objRSInsert.MoveFirst
iNewMessageId = objRSInsert.Fields("message_id")
If thread_id = 0 Then
objRSInsert.Fields("thread_id") = iNewMessageId
objRSInsert.Update
End If
objRSInsert.Close
Set objRSInsert = Nothing
InsertRecord = iNewMessageId
End Function 'InsertRecord
Sub SendEmailNotification(iNewMessageId, iThreadId, sPostersEmail)
' DB object var for email notification
Dim objNotifyRS
Dim strSQL
' Make sure emailing is enabled
If SEND_EMAIL Then
' Send Email notify if author has requested it
' thread_id = 0 -> this is the first post in thread -> no one to notify
If iThreadId <> 0 Then
strSQL = "SELECT DISTINCT message_author_email FROM messages WHERE "
strSQL = strSQL & "message_id <> " & iNewMessageId & " AND "
strSQL = strSQL & "thread_id = " & iThreadId & " AND "
strSQL = strSQL & "message_author_notify <> 0 AND "
strSQL = strSQL & "message_author_email <> '' AND "
strSQL = strSQL & "message_author_email <> '" & sPostersEmail & "';"
Set objNotifyRS = GetRecordset(strSQL)
If Not objNotifyRS.EOF Then
objNotifyRS.MoveFirst
Do While Not objNotifyRS.EOF
SendEmail _
"ASP 101 Webmaster ", _
objNotifyRS.Fields("message_author_email").Value, _
"A new message has been posted!", _
"A new message has been posted in a thread you asked us watch for you on ASP 101's " & _
"discussion forum. You can find the forum at http://www.asp101.com/forum. For " & _
"your convenience, the address of the new message is " & _
"http://www.asp101.com/forum/display_message.asp?mid=" & iNewMessageId & "."
objNotifyRS.MoveNext
Loop
End If
objNotifyRS.Close
Set objNotifyRS = Nothing
End If
End If
End Sub 'SendEmailNotification
Sub ShowThanks(iNewMessageId, iThreadParent, iForumId, sName, sEmail)
Response.Write "Thank you for your post! " & vbCrLf
Response.Write " " & vbCrLf
'ask if they want their stuff in a cookie?
If IsNull(Request.Cookies("name")) Or Len(Request.Cookies("name")) = 0 Then
Response.Write "NOTICE: Tired of typing in your name and email address "
Response.Write "for each post?
"
Response.Write "For your convenience, we can save your name and e-mail to a cookie on your "
Response.Write "machine so you won't need to enter them the next time you post a message. Click "
Response.Write "here to save this information now.
" & vbCrLf
else
' See if what they typed (name or email) oesn't match the cookie
If not isnull(Request.Cookies("name")) and (Request.Cookies("name") <> sName) Then
dim bNameDifferent
bNameDifferent = true
end if
If not isnull(Request.Cookies("email")) and (Request.Cookies("email") <> sEmail) Then
dim bEmailDifferent
bEmailDifferent = true
end if
if bNameDifferent and not bEmailDifferent then
Response.Write "NOTICE: "
Response.Write "The name you just used (" & sName & ") has changed since your last post.
"
Response.Write "To update your posting name from (" & Request.Cookies("name") & ") to (" & sName & "), click "
Response.Write "here - thanks!
" & vbCrLf
End If
if bEmailDifferent and not bNameDifferent then
Response.Write "NOTICE: "
Response.Write "The email address you just used (" & sEmail & ") has changed since your last post.
"
Response.Write "To update your posting email address from (" & Request.Cookies("email") & ") to (" & sEmail & "), click "
Response.Write "here - thanks!
" & vbCrLf
end if
if bEmailDifferent and bNameDifferent then
Response.Write "NOTICE: "
Response.Write "The email address you just used (" & sEmail & ") and name (" & sName & ") have changed since your last post.
