<%@ Language=VBScript %> <%Option Explicit%> <%Response.Buffer=True%> <% ' Get the latest messages for the RSS Feed Dim adoConn Dim adoRs Dim strSql Dim xmlfilename Dim NumItems Dim lngCurRSSMessageID Const bbDBPath = "../fpdb" Const bbDBName = "bbdata.mdb" Const strAdmTitle = "The Behold Discussion Forum" Set adoConn=Server.CreateObject("ADODB.Connection") adoConn.ConnectionString="DBQ=" & Server.MapPath(bbDBPath) & "\" & bbDBName & ";DefaultDir=" & Server.MapPath(bbDBPath) & ";Driver={Microsoft Access Driver (*.mdb)};DriverId=25;FIL=MS Access;ImplicitCommitSync=Yes;MaxBufferSize=512;MaxScanRows=8;PageTimeout=5;SafeTransactions=0;Threads=3;UID=admin;UserCommitSync=Yes;;User Id=admin;" On Error Resume Next adoConn.Open If Err.number <> 0 Then Response.Write "System Error

 

 

" Response.Write "ERROR  CANNOT OPEN DATABASE:

" Response.Write "" & Server.MapPath(bbDBPath) & "\" & bbDBName & "

" Response.Write "Please verify and correct the following lines in bbconst.asp:

" Response.Write "Const bbDBPath = """ & bbDBPath & """
" Response.Write "Const bbDBName = """ & bbDBName & """" Response.Write "

" Response.Write "The most common causes for database errors:" Response.Write "
  • bbDBPath does not point to the correct folder
    • " Response.Write "
  • Your database is not in a Read/Write folder
    • " Response.Write "

    " Response.End End If On Error GoTo 0 strSql = "SELECT tblMessages.*, tblBoards.BoardName, tblUsers.UserHandle" & _ " FROM (tblMessages INNER JOIN tblBoards ON tblMessages.MessageBoardId = tblBoards.BoardId) INNER JOIN tblUsers ON tblMessages.MessageUserId = tblUsers.UserId " & _ "WHERE (tblMessages.MessageValidStatus=1 AND tblBoards.BoardActiveStatus=1) " & _ "ORDER BY tblMessages.RecordCreateDate DESC" Set adoRs = Server.CreateObject("ADODB.Recordset") adoRs.ActiveConnection = adoConn adoRs.Source = strSql adoRs.CursorLocation = 3 'adUseClient adoRs.CursorType = 0 'adOpenForwardOnly adoRs.Locktype = 1 'adLockReadOnly adoRS.Open Set adoRs.ActiveConnection = Nothing ' Now update the RSS Feed for the Forum Response.Clear Response.Expires = 0 Response.ContentType="application/xml" ' xmlfilename="../behoforum.xml" xmlfilename="behoforum.xml" ' xmlfilename="../../cgi-bin/counts/behoforum.xml" Response.Write "" Response.Write " " Response.Write "" Response.Write " " Response.Write " " & strAdmTitle & "" Response.Write "" Response.Write " http://www.lkessler.com/behold/forum/" Response.Write " Copyright 2000-" & Year(Now) & " Louis Kessler, All Rights Reserved" Response.Write " This is the RSS Feed of the Discussion Forum for the genealogy program known as Behold" Response.Write " en-us" Response.Write "" Response.Write " " Response.Write " " & strAdmTitle & "" Response.Write " http://www.lkessler.com/behold/beholddiscuss.gif" Response.Write " http://www.lkessler.com/behold/forum/" Response.Write " 31" Response.Write " 32" Response.Write " " NumItems = 0 if adoRs.EOF then NumItems = 1000 end if Do Until NumItems >= 1000 NumItems = NumItems + 1 lngCurRSSMessageID = adoRs.Fields("MessageID").Value Response.Write "" Response.Write "" Response.Write " " & ReplaceQuotes(adoRs.Fields("MessageHeader").Value, 0) & "" Response.Write " " & adoRs.Fields("UserHandle").Value & "" Response.Write " " & adoRs.Fields("BoardName").Value & "" Response.Write "http://www.lkessler.com/behold/forum/detail.asp?Id=" & adoRs.Fields("MessageId").Value & "" Response.Write " http://www.lkessler.com/behold/forum/detail.asp?Id=" & adoRs.Fields("MessageId").Value & "" Response.Write " " & adoRs.Fields("UserHandle").Value & " on " & GetBoardDateTimeShort(adoRs.Fields("RecordCreateDate").Value) & " in " & adoRs.Fields("BoardName").Value Response.Write "

    " & ReplaceQuotes(adoRs.Fields("MessageDetail").Value, 0) Response.Write "]]>" Response.Write "" adoRs.MoveNext if adoRs.EOF then NumItems = 1000 else ' Don't include more than 50 items unless they are less than 2 weeks old if ((NumItems > 50) and adoRs.Fields("RecordCreateDate").Value < DateAdd("WW", -2, Date)) then NumItems = 1000 end if end if Loop Response.Write "" Response.Write "" Response.Write "" Set adoRs = Nothing Set adoConn = Nothing Function GetBoardDateTimeShort(pDate) Dim TimeString Dim OutTimeString TimeString = FormatDateTime(PDate, 3) if Mid(TimeString, 2, 1) = ":" then OutTimeString = Mid(TimeString, 1, 4) & Mid(TimeString, 8, 3) else OutTimeString = Mid(TimeString, 1, 5) & Mid(TimeString, 9, 3) end if GetBoardDateTimeShort = GetBoardDateShort(pDate) & OutTimeString End Function Function ReplaceQuotes(pstrInput, pintType) Dim strOutput '0 = Displaying '1 = Saving strOutput = pstrInput & "" If pintType = 0 Then strOutput = Replace(strOutput, "", "'") strOutput = Replace(strOutput, "", """") ' Also replace double
    with

    so that Feedreader looks okay strOutput = Replace(strOutput, "

    ", " 

    ") Else strOutput = Replace(strOutput, "'", "") strOutput = Replace(strOutput, """", "") End If ReplaceQuotes = strOutput End Function Function GetBoardDateShort(pDate) Dim intMonth Dim strExpDate Dim intweekday Dim strweekday intMonth = Month(pDate) Select Case intMonth Case 1 strExpDate = "Jan" Case 2 strExpDate = "Feb" Case 3 strExpDate = "Mar" Case 4 strExpDate = "Apr" Case 5 strExpDate = "May" Case 6 strExpDate = "Jun" Case 7 strExpDate = "Jul" Case 8 strExpDate = "Aug" Case 9 strExpDate = "Sep" Case 10 strExpDate = "Oct" Case 11 strExpDate = "Nov" Case 12 strExpDate = "Dec" End Select intWeekday = weekday(pDate) Select Case intWeekday Case 1 strWeekday = "Sun" Case 2 strWeekday = "Mon" Case 3 strWeekday = "Tue" Case 4 strWeekday = "Wed" Case 5 strWeekday = "Thu" Case 6 strWeekday = "Fri" Case 7 strWeekday = "Sat" End Select ' GetBoardDateShort = strWeekday & " " & Day(pDate) & " " & strExpDate & " " & Year(pDate) & " " GetBoardDateShort = Day(pDate) & " " & strExpDate & " " & Year(pDate) & " " End Function %>