<% ' comment_default.asp ' ' Comment default page ' hyBook version 2006.07.01 ' Copyright (c) 2006 by Dr. Herong Yang, http://www.herongyang.com/ Dim bgShowTopic, bgShowCommentList, bgShowCommentNew, ngTopicID, ngPage Dim sgError, sgNotice Dim sgName, sgEmail, sgContent bgShowTopic = True bgShowCommentList = True bgShowCommentNew = True bgShowTopicList = True %> <% Sub opening dbConnect ' Checking query string and form data sTopicID = myTrim(Request.Querystring("TopicID"),6) ngTopicID = Clng(sTopicID) sPage = myTrim(Request.Querystring("Page"),6) ngPage = Clng(sPage) If ngPage < 1 Then ngPage = 1 End If If Request.Form("submit") = "Skicka" Then sgName = myTrim(Request.Form("Name"),40) sgEmail = myTrim(Request.Form("Email"),40) sgContent = myTrim(Request.Form("Content"),2000) sTopicID = myTrim(Request.Form("TopicID"),6) ngTopicID = Clng(sTopicID) sgName = removeHTML(sgName) sgContent = removeHTML(sgContent) bOK = True ' Checking required values If bOK Then bOK = validateRequiredValue End If ' Checking required values If bOK Then bOK = validateContent End If ' Checking submit limit If bOK Then bOK = validateSubmitLimit End If ' Checking ngTopicID If bOK Then bOK = validateTopicID End If ' Checking to stop re-post If bOK Then bOK = validateRepost End If ' Submit data If bOK Then sName = Replace(sgName, "'", "''") sEmail = Replace(sgEmail, "'", "''") sContent = Replace(sgContent, "'", "''") sAddress = Request.ServerVariables("REMOTE_ADDR") sSQL = "INSERT INTO [hyComment] ([Name]," _ & " [Email]," _ & " [TopicID]," _ & " [Content]," _ & " [Timestamp]," _ & " [IpAddress])" _ & " VALUES ('" & sName & "'" _ & ", '" & sEmail & "'" _ & ", " & ngTopicID _ & ", '" & sContent & "'" _ & ", #" & date() & "#" _ & ", '" & sAddress & "')" If bgDebug Then ogDebug.WriteLine("sSQL = " & sSQL) End If ogConn.Execute(sSQL) sgNotice = "Din kommentar har lagts till. Tackar!" sgName = "" sgEmail = "" sgContent = "" Else sgName = Server.HTMLEncode(sgName) sgEmail = Server.HTMLEncode(sgEmail) sgContent = Server.HTMLEncode(sgContent) End If End If If ngTopicID = 0 Then ngTopicID = ngDefaultTopicID End If End Sub Function myTrim(sText,nLen) myTrim = sText If myTrim <> "" Then myTrim = Trim(sText) If Len(myTrim) > nLen Then myTrim = Mid(myTrim, 1, nLen) End If End If End Function Function validateSubmitLimit sAddress = Request.ServerVariables("REMOTE_ADDR") dYesterday = DateAdd("D", -1, DATE()) Set rSelect = Server.CreateObject("ADODB.Recordset") sSQL = "SELECT count(*) FROM [hyComment]" _ & " WHERE [IpAddress] = '" & sAddress & "'" _ & " AND [Timestamp] > #" & dYesterday & "#" rSelect.Open sSQL, ogConn If bgDebug Then ogDebug.WriteLine(sSQL) ogDebug.WriteLine("Count = " & rSelect.Fields(0)) End If If rSelect.Fields(0) < ngSubmitLimit Then validateSubmitLimit = True Else sgError = "Du har lagt in nog med meddelanden för en dag." _ & " vänligen återkom imorgon." validateSubmitLimit = False End If set rSelect = Nothing End Function Function validateTopicID Set rSelect = Server.CreateObject("ADODB.Recordset") sSQL = "SELECT * FROM [hyTopic] WHERE [ID] = " & ngTopicID rSelect.Open sSQL, ogConn If NOT rSelect.EOF Then validateTopicID = True Else sgError = "Felatigt topic ID var god försök igen." validateTopicID = False End If set rSelect = Nothing End Function Function validateRequiredValue If sgName <> "" AND sgContent <> "" AND sTopicID = "" Then validateRequiredValue = True Else sgError = "Du måste fylla i obligatoriska fält." _ & " Tryck på updatera och försök igen." validateRequiredValue = False End If End Function Function validateRepost sName = Replace(sgName, "'", "''") sEmail = Replace(sgEmail, "'", "''") sContent = Replace(sgContent, "'", "''") sAddress = Request.ServerVariables("REMOTE_ADDR") dYesterday = DateAdd("D", -1, DATE()) Set rSelect = Server.CreateObject("ADODB.Recordset") sSQL = "SELECT * FROM [hyComment]" _ & " WHERE [IpAddress] = '" & sAddress & "'" _ & " AND [Timestamp] > #" & dYesterday & "#" _ & " AND [Name] = '" & sName & "'" _ & " AND [Email] = '" & sEmail & "'" _ & " AND [Content] = '" & sContent & "'" _ & " AND [TopicID] = " & ngTopicID If bgDebug Then ogDebug.WriteLine(sSQL) End If rSelect.Open sSQL, ogConn If rSelect.EOF Then validateRepost = True Else sgError = "Du spammar, SLUTA!" _ & " Titta över om du stammar och försök igen." validateRepost = False End If set rSelect = Nothing End Function Function validateContent Dim RegEx Set RegEx = New RegExp bOK = True If bOK Then ' RegEx.Pattern = "[^ ^.]+\.[^ ^.]+" RegEx.Pattern = "\w+\.\w+" bOK = Not RegEx.Test(sgContent) If Not bOK Then sgError = "ajaj ditt meddelande innehåller en länk!" _ & " eller en email adress." _ & " Försök igen men inte nån URL eller email i meddelandet." End If End If If bOK Then RegEx.Pattern = "\S{31,}" bOK = Not RegEx.Test(sgContent) If Not bOK Then sgError = "så långa ord existerar inte" _ & " kolla över det." _ & " och försök igen." End If End If If bOK Then RegEx.Pattern = "HIMCC" bOK = RegEx.Test(sgEmail) If Not bOK Then sgError = "" _ & " Kolla över ditt inlägg." _ & " Och försök igen." _ & " Din adress är nog fel." End If End If If bOK Then RegEx.Pattern = "@mail.ru" bOK = Not RegEx.Test(sgEmail) If Not bOK Then sgError = "SPAM" _ & " kolla över det." _ & " och försök igen." End If End If If bOK Then RegEx.Pattern = "Greetings" bOK = Not RegEx.Test(sgContent) If Not bOK Then sgError = "SPAM" _ & " kolla över det." _ & " och försök igen." End If End If validateContent = bOK End Function Sub outputHeader End Sub Sub outputBody If sgError <> "" Then htmlError(sgError) sgError = "" End If If sgNotice <> "" Then htmlNotice(sgNotice) sgNotice = "" End If If bgShowTopic Then htmlTopic(ngTopicID) End If If bgShowCommentList Then htmlCommentList(ngTopicID) End If If bgShowCommentNew Then htmlCommentNew(ngTopicID) End If End Sub Sub outputFooter ' Do nothing End Sub Sub closing dbClose End Sub Function htmlTopic(ngTopicID) Set rsTopic = Server.CreateObject("ADODB.Recordset") sSQL = "SELECT * FROM hyTopic WHERE ID=" & ngTopicID If bgDebug Then ogDebug.WriteLine(sSQL) End If rsTopic.Open sSQL, ogConn If NOT rsTopic.EOF Then Response.Write("
") Response.Write(rsTopic("Subject")) Response.Write("
") Response.Write(replace(rsTopic("Content"), vbcrlf, "
")) Response.Write("
") Else htmlError("Felaktig data, försök igen.") bgShowCommentList = False bgShowCommentNew = False bgShowTopicList = False End If set rsTopic = Nothing End Function Function htmlCommentNew(ngTopicID) Response.Write("") Response.Write("") Response.Write("") Response.Write("" _ & "") Response.Write("" _ & "") Response.Write("" _ & "") Response.Write("" _ & "") Response.Write("") Response.Write("
Kommentar:(Obl.)
Namn:(Obligatoriskt)
Email:(Obligatoriskt)


" _ & "Notera att det du skriver i Email fältet inte publiceras i gästboken. Och att du där måste skriva himcc med stora bokstäver istället, för att det skall komma in.
" _ & "
") End Function Function removeHTML(strText) Dim RegEx Set RegEx = New RegExp RegEx.Pattern = "<[^>]*>" RegEx.Global = True RemoveHTML = RegEx.Replace(strText, "") End Function Function htmlCommentList(ngTopicID) sSQL = "SELECT COUNT(*) FROM [hyComment] WHERE [TopicID] =" _ & ngTopicID hylog "sSQL = " & sSQL Set rsSelect = Server.CreateObject("ADODB.Recordset") rsSelect.Open sSQL, ogConn nCount = rsSelect.Fields(0) nPages = (nCount-1) \ ngPageSize + 1 hyLog "ngPage = " & ngPage hyLog "nPages = " & nPages hyLog "nCount = " & nCount If nCount = 0 Then htmlNotice("tom kommentar.") ElseIf ngPage > nPages Then htmlError("felaktigt sidnummer.") Else nStart = 1 If ngPage > 0 Then nStart = (ngPage-1)*ngPageSize + 1 End If nTop = nStart + ngPageSize - 1 sSQL = "SELECT TOP " & nTop & " * FROM [hyComment] WHERE [TopicID] =" _ & ngTopicID & " ORDER BY ID DESC" hylog("sSQL = " & sSQL) Set rsComment = Server.CreateObject("ADODB.Recordset") rsComment.Open sSQL, ogConn Response.Write("") sURL = Request.ServerVariables("SCRIPT_NAME") sURL = sURL&"?TopicID="&ngTopicID htmlListHeader sURL, nCount, ngPageSize, ngPage ' Doing offset myself - need to find a better solution for this! nIndex = 1 Do While NOT rsComment.EOF AND nIndex < nStart nIndex = nIndex + 1 rsComment.MoveNext Loop sClass="hy_list_item_lo" Do While NOT rsComment.EOF AND nIndex <= nTop nIndex = nIndex + 1 Response.Write("") rsComment.MoveNext If sClass = "hy_list_item_lo" Then sClass = "hy_list_item_hi" Else sClass = "hy_list_item_lo" End If Loop Response.Write("
" _ & "

" _ & rsComment("Name") & " kommenterade " _ & rsComment("Timestamp") & ":

") Response.Write(replace(rsComment("Content"), vbcrlf, "
")_ & "

") set rsComment = Nothing End If End Function Sub htmlListHeader(sURL, nCount, nSize, nCurr) ' Assuming $sURL has "?..." ' Search Results: 11 - 20 of 259 matches. ' Pages: 1 2 3 nPages = (nCount-1) \ nSize + 1 nStart = (nCurr-1)*nSize+1 If nStart < 1 Then nStart = 1 End If nEnd = nStart + nSize - 1 If nEnd > nCount Then nEnd = nCount End If If nPages > 1 Then Response.Write("" _ & "Sidor: ") If nCurr>1 Then Response.Write(" <Föregående ") End If min = nCurr - 8 If min < 1 Then min = 1 End If max = nCurr + 8 If max > nPages Then max = nPages End If If min > 1 Then Response.Write(" ... ") End If For i = min To max If i = nCurr then Response.Write(" " & i & " ") Else Response.Write(" " & i & " ") End If Next If max < nPages Then Response.Write(" ... ") End If If nCurrNästa> ") End If Response.Write("") End If End Sub Function htmlNotice(sText) Response.Write("") Response.Write("") Response.Write("
" & sText & "
") End Function Function htmlError(sText) Response.Write("") Response.Write("") Response.Write("
" & sText & "
") End Function Function myDump aKeys = hgRqParam.Keys() ogDebug.WriteLine("Values in hgRqParam:") For i=0 To hgRqParam.Count-1 k = aKeys(i) ogDebug.WriteLine(k & " = (" & hgRqParam.Item(k) & ")") Next aKeys = hgPgParam.Keys() ogDebug.WriteLine("Values in hgPgParam:") For i=0 To hgRqParam.Count-1 k = aKeys(i) ogDebug.WriteLine(k & " = (" & hgPgParam.Item(k) & ")") Next End Function %>