12. April 2009

LIR eV

Neues Gästebuch, da im alten kein Spamfilter war

<% ' Guestbook settings Const gbpath = "../guestbook/" Const separateForm = false Const topForm = true Const notifywebmaster = false Const notifyemail = "" Const showtime = true Const emoticons = true Const smtpip = "" ' Constants for file opening Const ForReading = 1 Const ForWriting = 2 Const ForAppending = 8 ' Constants for fatal errors Const errorCreateDatFile = 530 Const errorReadDatFile = 531 Const errorWriteDatFile = 532 'Stops execution on fatal error '@param Code (int) Error code Function raiseFatalError(ByVal Code) Response.Write "" Response.End End Function ' Attempts to open the [@filename] file in [@iomode] mode ' ' @returns OnSuccess: TextStream object ' @returns OnFailure: Nothing Function gbOpenFile( ByVal filename, ByVal iomode ) On Error Resume Next ' set default return value Set gbOpenFile = Nothing Dim fileSystem Set fileSystem = CreateObject( "Scripting.FileSystemObject" ) If Not( fileSystem Is Nothing ) Then If fileSystem.FileExists( filename ) Then Set gbOpenFile = fileSystem.OpenTextFile( filename, iomode ) End If Set fileSystem = Nothing End If End Function ' Attempts to create the [@filename] file ' ' @returns OnSuccess: TextStream object ' @returns OnFailure: Nothing Function gbCreateFile( ByVal filename ) On Error Resume Next ' set default return value Set gbCreateFile = Nothing Dim fileSystem Set fileSystem = CreateObject( "Scripting.FileSystemObject" ) If Not( fileSystem Is Nothing ) Then Set gbCreateFile = fileSystem.CreateTextFile( filename, True ) Set fileSystem = Nothing End If End Function 'loads entries from the entries.dat file Function loadEntries Dim objFS, entries, textstream, f ' by default, entries are empty (contains only a newline character) entries = vbCr 'read guestbook entries into textstream Set objFS = Server.CreateObject( "Scripting.FileSystemObject" ) If objFS.FileExists( Server.MapPath( gbpath & "entries.dat" ) ) Then Set textstream = gbOpenFile( Server.MapPath( gbpath & "entries.dat" ), ForReading ) If textstream Is Nothing Then raiseFatalError errorReadDatFile Else entries = textstream.ReadAll textstream.Close End If Else Set f = gbCreateFile( Server.MapPath( gbpath & "entries.dat" ) ) If f Is Nothing Then raiseFatalError errorCreateDatFile response.End Else f.Write vbCr f.Close End If End If loadEntries = entries End Function 'generates a comment string from the post-ed information to this page Function generateComment Dim name, email, homepage, city, country, comment, signed, state 'read data entered into form name = CStr( Request.Form( "name" ) ) email = CStr( Request.Form( "email" ) ) homepage = CStr( Request.Form( "homepage" ) ) city = CStr( Request.Form( "city" ) ) country = CStr( Request.Form( "country" ) ) state = CStr( Request.Form( "state" ) ) comment = CStr( Request.Form( "comment" ) ) signed = FormatDateTime( Date, 1 ) & " " & Time Dim full full = "

" & vbCr 'print a comented line containing the fields (for editing purposes) full = full & "" & vbCr 'print each field if entered full = full & "

" If Not( name = "" ) Then full = full & "Name: " End If If Not( email = "" ) Then full = full & "" End If full = full & name If Not( email = "" ) Then full = full & "" End If full = full & "
" If Not( homepage = "" ) Then full = full & "Homepage: " & homepage & "
" End If If Not( city = "" ) Then full = full & "Stadt: " & city & "
" End If If Not( state = "" ) Then full = full & "Bundesland: " & state & "
" End If If Not( country = "" ) Then full = full & "Land: " & country & "
" End If If showtime = true Then full = full & "Gesendet: " & signed & "
" End If full = full & "

" comment = replace(comment, "<", "<") comment = replace(comment, ">", ">") comment = replace(comment, vbCrLf, "
") comment = replace(comment, vbCr, "
") comment = replace(comment, """", """) If emoticons = true Then comment = replace(comment, ":)", "

") comment = replace(comment, ":D", "

") comment = replace(comment, "=))", "

") comment = replace(comment, ":/", "

") comment = replace(comment, ":(", "

") comment = replace(comment, "X(", "

") comment = replace(comment, ":P", "

") comment = replace(comment, ";)", "

") End If full = full & "

" & comment & "

" & vbCr generateComment = full End Function 'adds a comment to the entries file Sub addComment Dim objFS, entries, textstream entries = loadEntries On error resume next Dim newComment newComment = generateComment Set textstream = gbOpenFile( Server.MapPath(gbpath & "entries.dat" ), ForWriting ) If textstream Is Nothing Then raiseFatalError errorWriteDatFile Else textstream.Write newComment textstream.Write entries textstream.Close End If 'Notify the webmaster If notifywebmaster = true Then Dim objCfg, objMail Dim strBody strBody = "Hallo, es wurde ein neuer Eintrag in Ihrem Gästebuch vorgenommen." & vbCrLf & vbCrLf strBody = strBody & "Name: " & CStr(Request.Form("name")) & vbCrLf & "Kommentar: " & CStr(Request.Form("comment")) Set objMail = Server.CreateObject("CDO.Message") Set objCfg = Server.CreateObject("CDO.Configuration") 'Out going SMTP server if smtpip <> "" then objCfg.Fields("http://schemas.microsoft.com/cdo/configuration/smtpserver") = smtpip end if objCfg.Fields("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2 objCfg.Fields("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = 60 objCfg.Fields.Update Set objMail.configuration = objCfg objMail.From = "guestbook" objMail.To = notifyemail objMail.Subject = "Neuer Gästebucheintrag" objMail.HtmlBody = strBody Err.Clear objMail.send Set objMail = Nothing Set objCfg = Nothing End If End Sub 'entry point Dim op op = Request.queryString( "op" ) If (op = "add") Then addComment 'reload this page Response.Redirect Request.ServerVariables( "URL" ) End If Dim entries entries = loadEntries %>

Gästebuch

<% If separateForm Then %> Kommentar hinzufügen <% End If %> <% entries = replace( entries, "$PATH", gbpath ) Response.Write entries & "

" %>