Option Explicit 'This is a Windows Scripting CGI file. It is a simple 'database chat program. ' This CGI only supports the forms GET method. That limits it ' to comments of somewhat less than 1000 characters (or ' whatever you can fit into a URL). ' ' If you use NT/2000 or IIS, please read this page on how ' to set up the Windows Script Host as a CGI service: ' http://support.microsoft.com/support/kb/articles/q221/0/81.asp ' On any generic web server with no security restrictions ' (like Fnord or Tiny), all you need to do is set scripting ' to run with CSCRIPT.EXE and with no logo. Do this with a ' command like this: ' CSCRIPT //H:CSCRIPT //Nologo //S ' ' On NT/2000, you will also need to be sure the IIS user ' account has permission to run the CSCRIPT executable. The ' IIS lockdown tool usually removes that permission. ' ' NOTE: If you use Win95/98 for your server platform you must ' modify this script! In the "ServerVariables" function, change ' the Windows NT/XP/2000 text ' CreateObject("Wscript.Shell").Environment("PROCESS").Item(strVariable) ' to Win95/98 text: ' CreateObject("Wscript.Shell").Environment.Item(strVariable) ' In the UNLIKELY event you don't have the Microsoft ' "Jet Engine" DAO database drivers, download from here: ' http://support.microsoft.com/?kbid=829558 Public Const DAO = "DAO.Dbengine.36" Main Sub Main Dim fs 'As Scripting.FileSystemObject Dim strTemp, strUserName, strComment, strIP 'As String Dim QueryString, Cookies 'As Scripting.Dictionary ''''''''''''First check to see if the chat database exists Set fs = CreateObject("Scripting.FileSystemObject") If Not fs.FileExists(FileNameLikeMine("mdb")) Then CreateDatabase 'Put query string data in a dictionary for easy access. strTemp = ServerVariables("QUERY_STRING") strTemp = Unescape(strTemp) Set QueryString = CreateDictionary(strTemp, "=", "&") 'Put cookies in a dictionary for easy access. strTemp = ServerVariables("HTTP_COOKIE") Set Cookies = CreateDictionary(strTemp, "=", "; ") ''''''''''''Look for missing fields If (Not QueryString.Exists("username")) Or (Not QueryString.Exists("comment")) Then ''''''''''''If no fields, then display the chat messages Wscript.Echo SendChat() Wscript.Quit End If ''''''''''''Check for missing or too short form data If (Len(QueryString.Item("username")) < 2) Or (Len(QueryString.Item("comment")) < 10) Then ''''''''''''Bad data gets you a new blank "add your comments" form. Wscript.Echo SendAddForm() Wscript.Quit End If ''''''''''''Good form fields mean we go ahead and add to the database strUserName = QueryString.Item("username") strComment = QueryString.Item("comment") strIP = CreateObject("WScript.Shell").Environment("Process").Item("REMOTE_ADDR") If strIP = "" Then strIP = "127.0.0.1" AddRecord strUserName, strComment, strIP ''''''''''''Now let the user see the chat comments Wscript.Echo SendChat() End Sub Function ServerVariables(strVariable) ServerVariables = CreateObject("Wscript.Shell").Environment("PROCESS").Item(strVariable) End Function Function Unescape(strEncodedText) 'As String 'This accepts a url-encoded string and returns the decoded value 'For example "counts=9%2E3&name=Eric+Phelps" becomes "counts=9.3&name=Eric Phelps" Dim strBuffer, strUnescape 'As String Dim lngPosition 'As Long strUnescape = strEncodedText 'Convert plusses to spaces Do While Instr(strUnescape, "+") <> 0 strUnescape = Replace(strUnescape, "+", " ") Loop 'Convert escaped hex values to normal (%61 = a) strBuffer = "" lngPosition = 1 Do If Mid(strUnescape, lngPosition, 1) = "%" Then strBuffer = strBuffer + Chr(Cint("&H" + Mid(strUnescape, lngPosition + 1, 2))) lngPosition = lngPosition + 3 Else strBuffer = strBuffer + Mid(strUnescape, lngPosition, 1) lngPosition = lngPosition + 1 End If Loop Until lngPosition > Len(strUnescape) Unescape = strBuffer End Function Function CreateDictionary(strQueryString, strItemSeparator, strEntrySeparator) 'As Scripting.Dictionary 'Accepts a multiply-delimited string and returns a dictionary. For example 'dict=CreateDictionary("counts=9.3&name=Eric Phelps", "=", "&") becomes available like this... 'dict("counts") will return "9.3", and dict("name") returns "Eric Phelps". 'Likewise dict.Exists("counts") is True and dict.Exists("xyftc") is False. Dim strQuery 'As String Dim strName 'As String Dim strValue 'As String Dim dict 'As Object Set dict = CreateObject("Scripting.Dictionary") strQuery = strQueryString Do While strQuery <> "" strName = Left(strQuery, InStr(strQuery, strItemSeparator) - 1) strQuery = Mid(strQuery, InStr(strQuery, strItemSeparator) + Len(strItemSeparator)) If InStr(strQuery, strEntrySeparator) = 0 Then strValue = strQuery strQuery = "" Else strValue = Left(strQuery, InStr(strQuery, strEntrySeparator) - 1) strQuery = Mid(strQuery, InStr(strQuery, strEntrySeparator) + Len(strEntrySeparator)) End If 'Allow for multiple items by tab-delimiting them If dict.Exists(strName) Then dict.Item(strName) = dict.Item(strName) & vbTab & strValue Else dict.Add strName, strValue End If Loop Set CreateDictionary = dict Set dict = Nothing End Function Function SendChat() 'As String 'Returns an html page with a table showing the data 'from the last 50 records in the chat database. Dim dbeng 'As DAO.Dbengine Dim db 'As Database Dim rs 'As Recordset Dim strOutput 'As String Dim lngPointer 'As Long Const dbOpenDynaset = 2 'DAO.RecordsetTypeEnum ''''''''''''Open the database and recordset Set dbeng = CreateObject(DAO) Set db = dbeng.OpenDatabase(FileNameLikeMine("mdb")) Set rs = db.OpenRecordset("chat", dbOpenDynaset) ''''''''''''Position at last fifty records rs.MoveLast lngPointer = rs.RecordCount - 50 If lngPointer < 0 Then lngPointer = 0 rs.AbsolutePosition = lngPointer ''''''''''''Send the headers strOutput = "HTTP/1.0 200 OK" & vbCrlf strOutput = strOutput & "Pragma: no-cache" & vbCrlf strOutput = strOutput & "Content-type: text/html" & vbCrlf & vbCrlf strOutput = strOutput & "VBS Chat Demo" ''''''''''''Walk thru the last fifty records and get the data Do Until rs.EOF strOutput = strOutput & "" rs.MoveNext Loop strOutput = strOutput & "
" strOutput = strOutput & rs.Fields("UserName").Value strOutput = strOutput & "
" strOutput = strOutput & CStr(rs.Fields("DateTime").Value) strOutput = strOutput & "
" strOutput = strOutput & rs.Fields("IP").Value strOutput = strOutput & "
" strOutput = strOutput & rs.Fields("Comment").Value strOutput = strOutput & "
" ''''''''''''Add a button at the bottom of the page to request a response form strOutput = strOutput & "
" strOutput = strOutput & "
" strOutput = strOutput & "" strOutput = strOutput & "
" strOutput = strOutput & "
" strOutput = strOutput & "
" strOutput = strOutput & "
" strOutput = strOutput & "" ''''''''''''Clean up Set rs = Nothing db.Close Set db = Nothing Set dbeng = Nothing ''''''''''''Return the results SendChat = strOutput End Function Sub CreateDatabase() 'Creates a database with the same root name as the script 'but with an mdb file extension. Initializes the new database 'with a table "chat" and a single record entry. Dim dbeng 'As DAO.Dbengine Dim db 'As Database Dim td 'As TableDef Dim fld 'As Field Dim rs 'As Recordset Const dbDate = 8 'DAO.DataTypeEnum Const dbText = 10 'DAO.DataTypeEnum Const dbMemo = 12 'DAO.DataTypeEnum Const dbLangGeneral = ";LANGID=0x0409;CP=1252;COUNTRY=0" 'DAO.LanguageConstants Set dbeng = CreateObject(DAO) ''''''''''''Create the database mdb file Set db = dbeng.CreateDatabase(FileNameLikeMine("mdb"), dbLangGeneral) ''''''''''''Create the table named chat Set td = db.CreateTableDef("chat") td.Fields.Append td.CreateField("UserName", dbText, 50) td.Fields.Append td.CreateField("IP", dbText, 15) td.Fields.Append td.CreateField("DateTime", dbDate) td.Fields.Append td.CreateField("Comment", dbMemo) db.TableDefs.Append td ''''''''''''Fill the first record with some data Set rs = db.OpenRecordset("chat") rs.AddNew rs.Fields("UserName").Value = "Administrator" rs.Fields("IP").Value = "127.0.0.1" rs.Fields("DateTime").Value = Now rs.Fields("Comment").Value = "Service initiated" rs.Update ''''''''''''Clean up db.Close Set rs = Nothing Set fld = Nothing Set td = Nothing Set db = Nothing Set dbeng = Nothing End Sub Sub AddRecord(strUserName, strComment, strIP) 'Accepts input from a form and adds a record to the chat database Dim dbeng 'As DAO.Dbengine Dim db 'As Database Dim rs 'As Recordset Const dbOpenDynaset = 2 'DAO.RecordsetTypeEnum Set dbeng = CreateObject(DAO) Set db = dbeng.OpenDatabase(FileNameLikeMine("mdb")) Set rs = db.OpenRecordset("chat", dbOpenDynaset) rs.MoveLast rs.AddNew rs.Fields("UserName").Value = strUserName rs.Fields("DateTime").Value = Now rs.Fields("IP").Value = strIP rs.Fields("Comment").Value = strComment rs.Update db.Close End Sub Function SendAddForm() 'As String Dim strAddForm 'As String ''''''''''''Send the headers strAddForm = "HTTP/1.0 200 OK" & vbCrlf strAddForm = strAddForm & "Pragma: no-cache" & vbCrlf strAddForm = strAddForm & "Content-type: text/html" & vbCrlf & vbCrlf strAddForm = strAddForm & "Add Your Comment" strAddForm = strAddForm & "
" strAddForm = strAddForm & "Your Name:

" strAddForm = strAddForm & "Your Comment:

" strAddForm = strAddForm & "
" strAddForm = strAddForm & "
" SendAddForm = strAddForm End Function Function FileNameLikeMine(strFileExtension) 'As String 'Returns a file name the same as the script name except 'for the file extension. Dim fs 'As Object Dim strExtension 'As String Set fs = CreateObject("Scripting.FileSystemObject") strExtension = strFileExtension If Len(strExtension) < 1 Then strExtension = "txt" If strExtension = "." Then strExtension = "txt" If Left(strExtension,1) = "." Then strExtension = Mid(strExtension, 2) FileNameLikeMine = Left(Wscript.ScriptFullName, InstrRev(Wscript.ScriptFullName, ".")) & strExtension End Function