<%
'#################################################################################
'## Copyright (c) 2001 Sean McGivern
'##
'## This program is free software; you can redistribute it and/or
'## modify it under the terms of the GNU General Public License
'## as published by the Free Software Foundation; either version 2
'## of the License, or any later version.
'##
'## All copyright notices regarding smNews must remain intact in the
'## scripts and in the outputted HTML. The "powered by" text with a
'## link back to http://www.tombstone.org.uk/sm/news/ in the footer
'## of the pages MUST remain visible when the pages are viewed on
'## the internet or intranet.
'##
'## This program is distributed in the hope that it will be useful,
'## but WITHOUT ANY WARRANTY; without even the implied warranty of
'## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
'## GNU General Public License for more details.
'##
'## You should have received a copy of the GNU General Public License
'## along with this program; if not, write to the Free Software
'## Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
'##
'## Correspondence and Questions can be sent to:
'## sean@tombstone.org.uk
'##
'#################################################################################
Option Explicit
Dim strDatabasePath, strLoginPassword, iPageSize, strTableName, strTitle
' ****************************************
' CONFIG VARIABLES
' ****************************************
strDatabasePath = Server.MapPath("sm.mdb")
' The physical path to the database for
' this smNews system. To use a virtual
' path, use Server.MapPath. Default is
' Server.MapPath("sm.mdb")
strLoginPassword = "password"
' The admin password for this smNews
' system. Default is "cheese".
iPageSize = 10
' The number of news items to display on
' each page. Default is 10.
strTableName = "News"
' The name of the database table which
' this smNews system will store its
' information in. Default is "News".
strTitle = "Latest News"
' The name of your site. Default is
' "smNews BETA 0.1".
' ****************************************
' END OF CONFIG VARIABLES
' ****************************************
Dim objConn
Set objConn = Server.CreateObject("ADODB.Connection")
Dim objRS
Set objRS = Server.CreateObject("ADODB.Recordset")
Dim iAdminFlag, strConnectionString, strRootURL, strText, strUserTitle
iAdminFlag = False
strRootURL = LCase(Request.ServerVariables("SCRIPT_NAME"))
strText = ""
strUserTitle = Trim(Request.Cookies("smNews")("UserTitle"))
If Trim(Request.Cookies("smNews")("Password")) = strLoginPassword Then
iAdminFlag = True
End If
strConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strDatabasePath & ";"
objConn.Open strConnectionString
Const adOpenStatic = 3
Dim qMode, qNewsID
qMode = LCase(Trim(Request.QueryString("mode")))
qNewsID = Trim(Request.QueryString("newsid"))
If qMode = "" Then
qMode = "display"
End If
If qNewsID = "" Then
qNewsID = Null
End If
strText = strText & "
" & vbCrLf
End Sub
' ****************************************
' END OF ADMIN
' ****************************************
' ****************************************
' ARCHIVE
' ****************************************
Sub Archive()
Dim strNewsID, strNewsTitle
iPageSize = iPageSize * 3
objRS.PageSize = iPageSize
objRS.CacheSize = iPageSize
objRS.Open TableSelectTop(strTableName, "NewsPosted", "DESC"), objConn, adOpenStatic
If objRS.EOF Then
Error("No news items to display.")
Exit Sub
End If
Dim qPage, iRecordsShown
qPage = Trim(Request.QueryString("page"))
If qPage = "" Then
qPage = 1
End If
objRS.AbsolutePage = qPage
Do While iRecordsShown < iPageSize And Not objRS.EOF
strNewsID = objRS.Fields("NewsID")
strNewsTitle = objRS.Fields("NewsTitle")
strText = strText & "
"
ElseIf qPage = 1 And iRecordsShown = iPageSize Then
strText = strText & "
"
End If
If iRecordsShown = iPageSize Then
strText = strText & "Next page
"
End If
End Sub
' ****************************************
' END OF ARCHIVE
' ****************************************
' ****************************************
' DELETE
' ****************************************
Sub Delete()
If iAdminFlag = False Then
strText = strText & Error("Access denied.")
Exit Sub
End If
If qNewsID = "" Then
strText = strText & Error("No NewsID specified.")
Exit Sub
End If
Dim qAction
qAction = LCase(Trim(Request.QueryString("action")))
If qAction = "sql" Then
Dim fNewsID, strSQL, fTool
fNewsID = Trim(Request.Form("newsid"))
fTool = Trim(Request.Form("tool"))
If fNewsID = "" Or fTool = "" Then
strText = strText & Error("There was a problem processing the form input. Please check all required fields are correctly filled in and try again.")
Exit Sub
End If
Select Case UCase(fTool)
Case "DELETE":
strSQL = "DELETE FROM " & strTableName & " " &_
"WHERE NewsID = " & fNewsID & ";"
objRS.Open strSQL, objConn
strText = strText & Success("NewsID " & fNewsID & " was deleted.")
Exit Sub
Case "NODELETE":
strText = strText & Success("NewsID " & fNewsID & " was not deleted.")
Exit Sub
End Select
End If
strText = strText & "
Delete
" & vbCrLf
strText = strText & "
Are you absolutely sure you want to delete NewsID " & qNewsID & "? There is no way to get it back once you do this.
" & vbCrLf
strText = strText & "" & vbCrLf
End Sub
' ****************************************
' END OF DELETE
' ****************************************
' ****************************************
' DISPLAY
' ****************************************
Sub Display()
Dim strNewsID, strNewsPosted, strUserTitle, strUserURL, strNewsTitle, strNewsText
If qNewsID <> "" Then
objRS.Open TableSelectWhere(strTableName, "NewsID", qNewsID), objConn, adOpenStatic
strNewsID = objRS.Fields("NewsID")
strNewsPosted = objRS.Fields("NewsPosted")
strUserTitle = objRS.Fields("UserTitle")
strUserURL = objRS.Fields("UserURL")
strNewsTitle = objRS.Fields("NewsTitle")
strNewsText = objRS.Fields("NewsText")
strText = strText & "
" & strNewsTitle
If iAdminFlag Then
strText = strText & " (Edit/Delete)"
End If
strText = strText & "
"
End Sub
' ****************************************
' END OF DISPLAY
' ****************************************
' ****************************************
' EDIT
' ****************************************
Sub Edit()
If iAdminFlag = False Then
strText = strText & Error("Access denied.")
Exit Sub
End If
Dim qAction
qAction = LCase(Trim(Request.QueryString("action")))
If qAction = "sql" Then
Dim fNewsID, fUserURL, fNewsTitle, fNewsText, strSQL
fNewsID = Trim(Request.Form("newsid"))
fUserURL = SQLText(Trim(Request.Form("userurl")))
fNewsTitle = SQLText(Trim(Request.Form("newstitle")))
fNewsText = SQLMemo(Trim(Request.Form("newstext")))
If fUserURL = "" Or fNewsTitle = "" Or fNewsText = "" Then
strText = strText & Error("There was a problem processing the form input. Please check all required fields are correctly filled in and try again.")
Exit Sub
End If
If fNewsID <> "" Then
strSQL = "UPDATE " & strTableName & " " &_
"SET UserURL = '" & fUserURL & "', " &_
"NewsTitle = '" & fNewsTitle & "', " &_
"NewsText = '" & fNewsText & "' " &_
"WHERE NewsID = " & fNewsID & ";"
objRS.Open strSQL, objConn
strText = strText & Success("News updated successfully.")
Exit Sub
Else
strSQL = "INSERT INTO " & strTableName & " (NewsPosted, UserTitle, UserURL, NewsTitle, NewsText) " &_
"VALUES (#" & Now() & "#, " &_
"'" & strUserTitle & "', " &_
"'" & fUserURL & "', " &_
"'" & fNewsTitle & "', " &_
"'" & fNewsText & "');"
objRS.Open strSQL, objConn
strText = strText & Success("News added successfully.")
Exit Sub
End If
End If
Dim strUserURL, strNewsTitle, strNewsText
If qNewsID <> "" Then
objRS.Open TableSelectWhere(strTableName, "NewsID", qNewsID), objConn, adOpenStatic
strUserURL = objRS.Fields("UserURL")
strNewsTitle = objRS.Fields("NewsTitle")
strNewsText = objRS.Fields("NewsText")
Else
strUserURL = Null
strNewsTitle = Null
strNewsText = Null
End If
strText = strText & "
" & vbCrLf
End Sub
' ****************************************
' END OF EDIT
' ****************************************
' ****************************************
' FUNCTIONS
' ****************************************
Function Error(strErrorMessage)
Error = "
" & strErrorMessage & "
"
End Function
' Formats errors in a nice way.
Function FormMemo(strFormMemo)
If strFormMemo <> "" Then
strFormMemo = Replace(strFormMemo, "''", "'")
strFormMemo = Replace(strFormMemo, "
", "")
FormMemo = strFormMemo
End If
End Function
' Formats a memo field from the database
' for use in a form field.
Function FormText(strFormText)
If strFormText <> "" Then
strFormText = Replace(strFormText, "''", "'")
strFormText = Replace(strFormText, "<", "<")
strFormText = Replace(strFormText, ">", ">")
FormText = strFormText
End If
End Function
' Formats a text field from the database for use
' in a form field.
Function Input(strInputType, strInputName, strInputWidth, strInputHeight, strInputValue)
Dim strInput
strInputType = LCase(strInputType)
strInputName = LCase(strInputName)
Select Case UCase(strInputType)
Case "TEXTAREA":
strInput = ""
Case Else:
strInput = " "hidden" And strInputType <> "submit" And strInputType <> "radio" And strInputType <> "checkbox" Then
strInput = strInput & "size=""" & strInputWidth & """ "
End If
If strInputType = "text" Or strInputType = "password" Then
strInput = strInput & "maxlength=""50"" "
End If
If strInputValue <> "" Then
strInput = strInput & "value=""" & strInputValue & """ "
End If
strInput = strInput & "/>"
End Select
Input = strInput
End Function
' Creates a form field.
Function SQLText(strSQLText)
strSQLText = Replace(strSQLText, "'", "''")
strSQLText = Replace(strSQLText, "<", "<")
strSQLText = Replace(strSQLText, ">", ">")
SQLText = strSQLText
End Function
' Formats text for use in UPDATE and
' INSERT INTO statements.
Function SQLMemo(strSQLMemo)
strSQLMemo = Replace(strSQLMemo, "'", "''")
strSQLMemo = Replace(strSQLMemo, Chr(13), "")
strSQLMemo = Replace(strSQLMemo, Chr(10) & Chr(10), "
"
SQLMemo = strSQLMemo
End Function
' Formats textareas for use in UPDATE and
' INSERT INTO statements.
Function Success(strSuccessMessage)
Success = "
" & strSuccessMessage & "
"
End Function
' Formats success messages in a nice way.
Function TableFields(strTable)
Select Case UCase(strTable)
Case UCase(strTableName):
TableFields = "NewsID, NewsPosted, UserTitle, UserURL, NewsTitle, NewsText"
End Select
End Function
' This function appears a little
' pointless, but I'm using it for
' scalability.
Function TableSelectTop(strTable, strTableField, strSelectDirection)
TableSelectTop = "SELECT " & TableFields(strTable) & " " &_
"FROM " & strTable & " " &_
"ORDER BY " & strTableField & " " &_
UCase(strSelectDirection) & ";"
End Function
' Selects every field from every record in
' a table, ordering them in the process.
Function TableSelectWhere(strTable, strTableField, strSelectValue)
Dim strTableSelectWhere
TableSelectWhere = "SELECT " & TableFields(strTable) & " " &_
"FROM " & strTable & " " &_
"WHERE (((" & strTableField & ") " &_
"= " & strSelectValue & ")) ;"
End Function
' Selects every field from a record in a
' table, where that record contains the
' field and value requested.
' ****************************************
' END OF FUNCTIONS
' ****************************************
strText = strText & ""
objConn.Close
Set objConn = Nothing
%>
<%= strTitle %>