") fString = Replace(fString, CHR(10), "
") if strBadWordFilter = 1 then fString = ChkBadWords(fString) end if fString = ChkUrls(fString,"http://", 1) fString = ChkUrls(fString,"https://", 2) fString = ChkUrls(fString,"file:///", 3) fString = ChkUrls(fString,"www.", 4) fString = ChkUrls(fString,"mailto:",5) fString = ChkMail(fString," ",5) 'fString = edit_hrefs(fString, 5) fString = ReplaceUrls(fString) FormatStr = fString end function function doublenum(fNum) if fNum > 9 then doublenum = fNum else doublenum = "0" & fNum end if end function function widenum(fNum) if fNum > 9 then widenum = "" else widenum = " " end if end function function chked(fYN) if fYN = "yes" or fYN = "1" or fYN = 1 then '** chked = " Checked" else chked = "" end if end function function doCode(fString, fOTag, fCTag, fROTag, fRCTag) fOTagPos = Instr(1, fString, fOTag, 1) fCTagPos = Instr(1, fString, fCTag, 1) while (fCTagPos > 0 and fOTagPos > 0) fString = replace(fString, fOTag, fROTag, 1, 1, 1) fString = replace(fString, fCTag, fRCTag, 1, 1, 1) fOTagPos = Instr(1, fString, fOTag, 1) fCTagPos = Instr(1, fString, fCTag, 1) wend doCode = fString end function function CleanCode(fString) if fString = "" then fString = " " else if strAllowForumCode = "1" then fString = replace(fString, "","[b]", 1, -1, 1) fString = replace(fString, "","[/b]", 1, -1, 1) fString = replace(fString, "", "[s]", 1, -1, 1) fString = replace(fString, "", "[/s]", 1, -1, 1) fString = replace(fString, "","[u]", 1, -1, 1) fString = replace(fString, "","[/u]", 1, -1, 1) fString = replace(fString, "","[i]", 1, -1, 1) fString = replace(fString, "","[/i]", 1, -1, 1) fString = replace(fString, "", "[font=Andale Mono]", 1, -1, 1) fString = replace(fString, "", "[/font=Andale Mono]", 1, -1, 1) fString = replace(fString, "", "[font=Arial]", 1, -1, 1) fString = replace(fString, "", "[/font=Arial]", 1, -1, 1) fString = replace(fString, "", "[font=Arial Black]", 1, -1, 1) fString = replace(fString, "", "[/font=Arial Black]", 1, -1, 1) fString = replace(fString, "", "[font=Book Antiqua]", 1, -1, 1) fString = replace(fString, "", "[/font=Book Antiqua]", 1, -1, 1) fString = replace(fString, "", "[font=Century Gothic]", 1, -1, 1) fString = replace(fString, "", "[/font=Century Gothic]", 1, -1, 1) fString = replace(fString, "", "[font=Comic Sans MS]", 1, -1, 1) fString = replace(fString, "", "[/font=Comic Sans MS]", 1, -1, 1) fString = replace(fString, "", "[font=Courier New]", 1, -1, 1) fString = replace(fString, "", "[/font=Courier New]", 1, -1, 1) fString = replace(fString, "", "[font=Georgia]", 1, -1, 1) fString = replace(fString, "", "[/font=Georgia]", 1, -1, 1) fString = replace(fString, "", "[font=Impact]", 1, -1, 1) fString = replace(fString, "", "[/font=Impact]", 1, -1, 1) fString = replace(fString, "", "[font=Tahoma]", 1, -1, 1) fString = replace(fString, "", "[/font=Tahoma]", 1, -1, 1) fString = replace(fString, "", "[font=Times New Roman]", 1, -1, 1) fString = replace(fString, "", "[/font=Times New Roman]", 1, -1, 1) fString = replace(fString, "", "[font=Trebuchet MS]", 1, -1, 1) fString = replace(fString, "", "[/font=Trebuchet MS]", 1, -1, 1) fString = replace(fString, "", "[font=Script MT Bold]", 1, -1, 1) fString = replace(fString, "", "[/font=Script MT Bold]", 1, -1, 1) fString = replace(fString, "", "[font=Stencil]", 1, -1, 1) fString = replace(fString, "", "[/font=Stencil]", 1, -1, 1) fString = replace(fString, "", "[font=Verdana]", 1, -1, 1) fString = replace(fString, "", "[/font=Verdana]", 1, -1, 1) fString = replace(fString, "", "[font=Lucida Console]", 1, -1, 1) fString = replace(fString, "", "[/font=Lucida Console]", 1, -1, 1) fString = replace(fString, "", "[red]", 1, -1, 1) fString = replace(fString, "", "[/red]", 1, -1, 1) fString = replace(fString, "", "[green]", 1, -1, 1) fString = replace(fString, "", "[/green]", 1, -1, 1) fString = replace(fString, "", "[blue]", 1, -1, 1) fString = replace(fString, "", "[/blue]", 1, -1, 1) fString = replace(fString, "", "[white]", 1, -1, 1) fString = replace(fString, "", "[/white]", 1, -1, 1) fString = replace(fString, "", "[purple]", 1, -1, 1) fString = replace(fString, "", "[/purple]", 1, -1, 1) fString = replace(fString, "", "[yellow]", 1, -1, 1) fString = replace(fString, "", "[/yellow]", 1, -1, 1) fString = replace(fString, "", "[violet]", 1, -1, 1) fString = replace(fString, "", "[/violet]", 1, -1, 1) fString = replace(fString, "", "[brown]", 1, -1, 1) fString = replace(fString, "", "[/brown]", 1, -1, 1) fString = replace(fString, "", "[black]", 1, -1, 1) fString = replace(fString, "", "[/black]", 1, -1, 1) fString = replace(fString, "", "[pink]", 1, -1, 1) fString = replace(fString, "", "[/pink]", 1, -1, 1) fString = replace(fString, "", "[orange]", 1, -1, 1) fString = replace(fString, "", "[/orange]", 1, -1, 1) fString = replace(fString, "", "[gold]", 1, -1, 1) fString = replace(fString, "", "[/gold]", 1, -1, 1) fString = replace(fString, "", "[beige]", 1, -1, 1) fString = replace(fString, "", "[/beige]", 1, -1, 1) fString = replace(fString, "", "[teal]", 1, -1, 1) fString = replace(fString, "", "[/teal]", 1, -1, 1) fString = replace(fString, "", "[navy]", 1, -1, 1) fString = replace(fString, "", "[/navy]", 1, -1, 1) fString = replace(fString, "", "[maroon]", 1, -1, 1) fString = replace(fString, "", "[/maroon]", 1, -1, 1) fString = replace(fString, "", "[limegreen]", 1, -1, 1) fString = replace(fString, "", "[/limegreen]", 1, -1, 1) fString = replace(fString, "

", "[h1]", 1, -1, 1) fString = replace(fString, "

", "[h2]", 1, -1, 1) fString = replace(fString, "

", "[h3]", 1, -1, 1) fString = replace(fString, "

", "[h4]", 1, -1, 1) fString = replace(fString, "

", "[h5]", 1, -1, 1) fString = replace(fString, "

", "[h6]", 1, -1, 1) fString = replace(fString, "

","[list]", 1, -1, 1) fString = replace(fString, "

","[list=1]", 1, -1, 1) fString = replace(fString, "

","[list=a]", 1, -1, 1) fString = replace(fString, "

quote:

---

","[quote]", 1, -1, 1) fString = replace(fString, "

---

","[/quote]", 1, -1, 1) fString = replace(fString, "

","[code]", 1, -1, 1)
			fString = replace(fString, "

","[/code]", 1, -1, 1) if strIMGInPosts = "1" then fString = replace(fString, "","[/img]", 1, -1, 1) fString = replace(fString, """ id=right border=0>","[/img=right]", 1, -1, 1) fString = replace(fString, """ id=left border=0>","[/img=left]", 1, -1, 1) end if end if if strIcons = "1" then fString= replace(fString, "", "[:(!]", 1, -1, 1) fString= replace(fString, "", "[B)]", 1, -1, 1) fString= replace(fString, "", "[xx(]", 1, -1, 1) fString= replace(fString, "", "[XX(]", 1, -1, 1) fString= replace(fString, "", "[:O]", 1, -1, 1) fString= replace(fString, "", "[:o]", 1, -1, 1) fString= replace(fString, "", "[:0]", 1, -1, 1) fString= replace(fString, "", "[:I]", 1, -1, 1) fString= replace(fString, "", "[:(]", 1, -1, 1) fString= replace(fString, "", "[8)]", 1, -1, 1) fString= replace(fString, "", "[:)]", 1, -1, 1) fString= replace(fString, "", "[}:)]", 1, -1, 1) fString= replace(fString, "", "[:D]", 1, -1, 1) fString= replace(fString, "", "[8D]", 1, -1, 1) fString= replace(fString, "", "[|)]", 1, -1, 1) fString= replace(fString, "", "[:o)]", 1, -1, 1) fString= replace(fString, "", "[:O)]", 1, -1, 1) fString= replace(fString, "", "[:0)]", 1, -1, 1) fString= replace(fString, "", "[:P]", 1, -1, 1) fString= replace(fString, "", "[:p]", 1, -1, 1) fString= replace(fString, "", "[;)]", 1, -1, 1) fString= replace(fString, "", "[8]", 1, -1, 1) fString= replace(fString, "", "[?]", 1, -1, 1) fString= replace(fString, "", "[^]", 1, -1, 1) fString= replace(fString, "", "[V]", 1, -1, 1) fString= replace(fString, "", "[v]", 1, -1, 1) fString= replace(fString, "", "[:X]", 1, -1, 1) fString= replace(fString, "", "[:x]", 1, -1, 1) end if end if fString = Replace(fString, "'", "'") CleanCode = fString end function function Smile(fString) fString = replace(fString, "[:(!]", "") fString = replace(fString, "[B)]", "") fString = replace(fString, "[xx(]", "") fString = replace(fString, "[XX(]", "") fString = replace(fString, "[:I]", "") fString = replace(fString, "[:(]", "") fString = replace(fString, "[:o]", "") fString = replace(fString, "[:O]", "") fString = replace(fString, "[:0]", "") fString = replace(fString, "[|)]", "") fString = replace(fString, "[:)]", "") fString = replace(fString, "[:D]", "") fString = replace(fString, "[}:)]", "") fString = replace(fString, "[:o)]", "") fString = replace(fString, "[:O)]", "") fString = replace(fString, "[:0)]", "") fString = replace(fString, "[8)]", "") fString = replace(fString, "[8D]", "") fString = replace(fString, "[:P]", "") fString = replace(fString, "[:p]", "") fString = replace(fString, "[;)]", "") fString = replace(fString, "[8]", "") fString = replace(fString, "[?]", "") fString = replace(fString, "[^]", "") fString = replace(fString, "[V]", "") fString = replace(fString, "[v]", "") fString = replace(fString, "[:X]", "") fString = replace(fString, "[:x]", "") Smile = fString end function function chkNameBadWords(fString) bwords = split(strBadWords, "|") for i = 0 to ubound(bwords) if instr(fString, bwords(i)) <> 0 then Err_Msg = Err_Msg & "

Username may not contain the word " & bwords(i) & "

" exit function end if next end function function chkBadWords(pString) fString = trim(pString) if fString = "" or IsNull(fString) then fString = " " bwords = split(strBadWords, "|") for i = 0 to ubound(bwords) fString = Replace(fString, bwords(i), string(len(bwords(i)),"*"), 1,-1,1) next chkBadWords = fString end function function HTMLEncode(pString) fString = trim(pString) if fString = "" or IsNull(fString) then fString = " " fString = replace(fString, ">", ">") fString = replace(fString, "<", "<") HTMLEncode = fString end function function HTMLDecode(pString) fString = trim(pString) if fString = "" then fString = " " fString = replace(fString, ">", ">") fString = replace(fString, "<", "<") HTMLDecode = fString end function function chkString(pString,fField_Type) '## Types - name, password, title, message, url, urlpath, email, number, list fString = trim(pString) if fString = "" then fString = " " else ' chkBadWords(fString) end if if fField_Type = "archive" then fString = Replace(fString, "'", "''") chkString = fString exit function end if if fField_Type = "displayimage" then fString = Replace(fString, " ", "") fString = Replace(fString, """", "") fString = Replace(fString, "<", "") fString = Replace(fString, ">", "") chkString = fString exit function end if if fField_Type = "title" then if strAllowHTML <> "1" then fString = HTMLEncode(fString) end if chkBadWords(fString) chkString = fString exit function end if if fField_Type = "password" then fString = trim(fString) chkString = fString end if if fField_Type = "decode" then fString = HTMLDecode(fString) chkString = fString exit function end if if fField_Type = "urlpath" then fString = Server.URLEncode(fString) chkString = fString exit function end if if fField_Type = "SQLString" then fString = Replace(fString, "'", "''") fString = HTMLEncode(fString) chkString = fString exit function end if if fField_Type = "JSurlpath" then fString = Replace(fString, "'", "\'") fString = Server.URLEncode(fString) chkString = fString exit function end if if fField_Type = "edit" then if strAllowHTML <> "1" then fString = HTMLEncode(fString) end if fString = Replace(fString, """", """) ChkString = fString exit function end if if fField_Type = "display" then if strAllowHTML <> "1" then fString = HTMLEncode(fString) end if chkString = fString exit function elseif fField_Type = "message" then if strAllowHTML <> "1" then fString = HTMLEncode(fString) end if elseif fField_Type = "preview" then if strAllowHTML <> "1" then fString = HTMLEncode(fString) end if elseif fField_Type = "hidden" then fString = HTMLEncode(fString) end if if strAllowForumCode = "1" and fField_Type <> "signature" then fString = doCode(fString, "[b]", "[/b]", "", "") fString = doCode(fString, "[s]", "[/s]", "", "") fString = doCode(fString, "[strike]", "[/strike]", "", "") fString = doCode(fString, "[u]", "[/u]", "", "") fString = doCode(fString, "[i]", "[/i]", "", "") if fField_Type <> "title" then fString = doCode(fString, "[font=Andale Mono]", "[/font=Andale Mono]", "", "") fString = doCode(fString, "[font=Arial]", "[/font=Arial]", "", "") fString = doCode(fString, "[font=Arial Black]", "[/font=Arial Black]", "", "") fString = doCode(fString, "[font=Book Antiqua]", "[/font=Book Antiqua]", "", "") fString = doCode(fString, "[font=Century Gothic]", "[/font=Century Gothic]", "", "") fString = doCode(fString, "[font=Courier New]", "[/font=Courier New]", "", "") fString = doCode(fString, "[font=Comic Sans MS]", "[/font=Comic Sans MS]", "", "") fString = doCode(fString, "[font=Georgia]", "[/font=Georgia]", "", "") fString = doCode(fString, "[font=Impact]", "[/font=Impact]", "", "") fString = doCode(fString, "[font=Tahoma]", "[/font=Tahoma]", "", "") fString = doCode(fString, "[font=Times New Roman]", "[/font=Times New Roman]", "", "") fString = doCode(fString, "[font=Trebuchet MS]", "[/font=Trebuchet MS]", "", "") fString = doCode(fString, "[font=Script MT Bold]", "[/font=Script MT Bold]", "", "") fString = doCode(fString, "[font=Stencil]", "[/font=Stencil]", "", "") fString = doCode(fString, "[font=Verdana]", "[/font=Verdana]", "", "") fString = doCode(fString, "[font=Lucida Console]", "[/font=Lucida Console]", "", "") fString = doCode(fString, "[red]", "[/red]", "", "") fString = doCode(fString, "[green]", "[/green]", "", "") fString = doCode(fString, "[blue]", "[/blue]", "", "") fString = doCode(fString, "[white]", "[/white]", "", "") fString = doCode(fString, "[purple]", "[/purple]", "", "") fString = doCode(fString, "[yellow]", "[/yellow]", "", "") fString = doCode(fString, "[violet]", "[/violet]", "", "") fString = doCode(fString, "[brown]", "[/brown]", "", "") fString = doCode(fString, "[black]", "[/black]", "", "") fString = doCode(fString, "[pink]", "[/pink]", "", "") fString = doCode(fString, "[orange]", "[/orange]", "", "") fString = doCode(fString, "[gold]", "[/gold]", "", "") fString = doCode(fString, "[beige]", "[/beige]", "", "") fString = doCode(fString, "[teal]", "[/teal]", "", "") fString = doCode(fString, "[navy]", "[/navy]", "", "") fString = doCode(fString, "[maroon]", "[/maroon]", "", "") fString = doCode(fString, "[limegreen]", "[/limegreen]", "", "") fString = doCode(fString, "[h1]", "[/h1]", "

", "

") fString = doCode(fString, "[h2]", "[/h2]", "

", "

") fString = doCode(fString, "[h3]", "[/h3]", "

", "

") fString = doCode(fString, "[h4]", "[/h4]", "

", "

") fString = doCode(fString, "[h5]", "[/h5]", "

", "

") fString = doCode(fString, "[h6]", "[/h6]", "

", "

") fString = doCode(fString, "[size=1]", "[/size=1]", "", "") fString = doCode(fString, "[size=2]", "[/size=2]", "", "") fString = doCode(fString, "[size=3]", "[/size=3]", "", "") fString = doCode(fString, "[size=4]", "[/size=4]", "", "") fString = doCode(fString, "[size=5]", "[/size=5]", "", "") fString = doCode(fString, "[size=6]", "[/size=6]", "", "") fString = doCode(fString, "[list]", "[/list]", "

", "

") fString = doCode(fString, "[list=1]", "[/list=1]", "

", "

") fString = doCode(fString, "[list=a]", "[/list=a]", "

", "

") fString = doCode(fString, "[*]", "[/*]", "

", "

") fString = doCode(fString, "[left]", "[/left]", "

", "

") fString = doCode(fString, "[center]", "[/center]", "", "") fString = doCode(fString, "[centre]", "[/centre]", "", "") fString = doCode(fString, "[right]", "[/right]", "

", "

") fString = doCode(fString, "[code]", "[/code]", "

", "

") fString = doCode(fString, "[quote]", "[/quote]", "

quote:

---

", "

---

") fString = replace(fString, "[br]", "
", 1, -1, 1) if strIMGInPosts = "1" then fString = ReplaceImageTags(fString) end if end if end if if strIcons = "1" and _ fField_Type <> "title" and _ fField_Type <> "hidden" then fString= smile(fString) end if if fField_Type <> "hidden" and _ fField_Type <> "preview" then fString = Replace(fString, "'", "''") end if chkString = fString end function function chkNotEmpty(fString) dim i, ch for i = 1 to Len(fString) select case Mid(fString, i, 1) case vbTab, vbLf, vbCr, vbNewline chkNotEmpty = false case else chkNotEmpty = true exit for end select next end function function chkDateTime(fDateTime) if fDateTime = "" then exit function end if if IsDate(fDateTime) then select case strDateType case "dmy" chkDateTime = Mid(fDateTime,7,2) & "/" & _ Mid(fDateTime,5,2) & "/" & _ Mid(fDateTime,1,4) case "mdy" chkDateTime = Mid(fDateTime,5,2) & "/" & _ Mid(fDateTime,7,2) & "/" & _ Mid(fDateTime,1,4) case "ymd" chkDateTime = Mid(fDateTime,1,4) & "/" & _ Mid(fDateTime,5,2) & "/" & _ Mid(fDateTime,7,2) case "ydm" chkDateTime =Mid(fDateTime,1,4) & "/" & _ Mid(fDateTime,7,2) & "/" & _ Mid(fDateTime,5,2) case "dmmy" chkDateTime = Mid(fDateTime,7,2) & " " & _ Monthname(Mid(fDateTime,5,2),1) & " " & _ Mid(fDateTime,1,4) case "mmdy" chkDateTime = Monthname(Mid(fDateTime,5,2),1) & " " & _ Mid(fDateTime,7,2) & " " & _ Mid(fDateTime,1,4) case "ymmd" chkDateTime = Mid(fDateTime,1,4) & " " & _ Monthname(Mid(fDateTime,5,2),1) & " " & _ Mid(fDateTime,7,2) case "ydmm" chkDateTime = Mid(fDateTime,1,4) & " " & _ Mid(fDateTime,7,2) & " " & _ Monthname(Mid(fDateTime,5,2),1) case "dmmmy" chkDateTime = Mid(fDateTime,7,2) & " " & _ Monthname(Mid(fDateTime,5,2),0) & " " & _ Mid(fDateTime,1,4) case "mmmdy" chkDateTime = Monthname(Mid(fDateTime,5,2),0) & " " & _ Mid(fDateTime,7,2) & " " & _ Mid(fDateTime,1,4) case "ymmmd" chkDateTime = Mid(fDateTime,1,4) & " " & _ Monthname(Mid(fDateTime,5,2),0) & " " & _ Mid(fDateTime,7,2) case "ydmmm" chkDateTime = Mid(fDateTime,1,4) & " " & _ Mid(fDateTime,7,2) & " " & _ Monthname(Mid(fDateTime,5,2),0) case else chkDateTime = doublenum(Mid(fDateTime,5,2)) & "/" & _ Mid(fDateTime,7,2) & "/" & _ Mid(fDateTime,1,4) end select if strTimeType = 12 then if cint(Mid(fDateTime, 9,2)) > 12 then chkDateTime = chkDateTime & " " & _ (cint(Mid(fDateTime, 9,2)) -12) & ":" & _ Mid(fDateTime, 11,2) & ":" & _ Mid(fDateTime, 13,2) & " " & "PM" elseif cint(Mid(fDateTime, 9,2)) = 12 then chkDateTime = chkDateTime & " " & _ cint(Mid(fDateTime, 9,2)) & ":" & _ Mid(fDateTime, 11,2) & ":" & _ Mid(fDateTime, 13,2) & " " & "PM" elseif cint(Mid(fDateTime, 9,2)) = 0 then chkDateTime = chkDateTime & " " & _ (cint(Mid(fDateTime, 9,2)) +12) & ":" & _ Mid(fDateTime, 11,2) & ":" & _ Mid(fDateTime, 13,2) & " " & "AM" else chkDateTime = chkDateTime & " " & _ Mid(fDateTime, 9,2) & ":" & _ Mid(fDateTime, 11,2) & ":" & _ Mid(fDateTime, 13,2) & " " & "AM" end if else chkDateTime = chkDateTime & " " & _ Mid(fDateTime, 9,2) & ":" & _ Mid(fDateTime, 11,2) & ":" & _ Mid(fDateTime, 13,2) end if end if end function function chkDateFormat(strDateTime) chkDateFormat = isdate("" & Mid(strDateTime, 5,2) & "/" & Mid(strDateTime, 7,2) & "/" & Mid(strDateTime, 1,4) & " " & Mid(strDateTime, 9,2) & ":" & Mid(strDateTime, 11,2) & ":" & Mid(strDateTime, 13,2) & "") end function function OldstrToDate(strDateTime) if chkDateFormat(strDateTime) then StrToDate = cdate("" & Mid(strDateTime, 5,2) & "/" & Mid(strDateTime, 7,2) & "/" & Mid(strDateTime, 1,4) & " " & Mid(strDateTime, 9,2) & ":" & Mid(strDateTime, 11,2) & ":" & Mid(strDateTime, 13,2) & "") else strToDate = "" & strForumTimeAdjust end if end function function StrToDate(strDateTime) if ChkDateFormat(strDateTime) then StrToDate = cdate("" & Mid(strDateTime, 5,2) & "/" & Mid(strDateTime, 7,2) & "/" & Mid(strDateTime, 1,4) & " " & Mid(strDateTime, 9,2) & ":" & Mid(strDateTime, 11,2) & ":" & Mid(strDateTime, 13,2) & "") else tmpDate = DatePart("m",strForumTimeAdjust) & "/" & DatePart("d",strForumTimeAdjust) & "/" & DatePart("yyyy",strForumTimeAdjust) & " " & DatePart("h",strForumTimeAdjust) & ":" & DatePart("n",strForumTimeAdjust) & ":" & DatePart("s",strForumTimeAdjust) StrToDate = "" & tmpDate end if end function function DateToStr(dtDateTime) if not isDate(strForumTimeAdjust) then strForumTimeAdjust = strToDate(strForumTimeAdjust) end if DateToStr = year(dtDateTime) & doublenum(Month(dtdateTime)) & doublenum(Day(dtdateTime)) & doublenum(Hour(dtdateTime)) & doublenum(Minute(dtdateTime)) & doublenum(Second(dtdateTime)) & "" end function function ReadLastHereDate(UserName) dim TempLastHereDate dim rs_date dim strSql ' if UserName = "" then ' exit function ' end if if not isDate(strForumTimeAdjust) then strForumTimeAdjust = strToDate(strForumTimeAdjust) end if '## Forum_SQL strSql = "SELECT " & strMemberTablePrefix & "MEMBERS.M_LASTHEREDATE " strSql = strSql & " FROM " & strMemberTablePrefix & "MEMBERS " strSql = strSql & " WHERE " & strMemberTablePrefix & "MEMBERS."&Strdbntsqlname&" = '" & ChkString(UserName, "SQLString") & "' " Set rs_date = Server.CreateObject("ADODB.Recordset") rs_date.open strSql, my_Conn if (rs_date.BOF and rs_date.EOF) then TempLastHereDate = DateAdd("d",-10,strForumTimeAdjust) else TempLastHereDate = StrToDate(rs_date("M_LASTHEREDATE")) if TempLastHereDate = "" or IsNull(TempLastHereDate) then TempLastHereDate = DateAdd("d",-10,strForumTimeAdjust) end if end if rs_date.close set rs_date = nothing '## Forum_SQL - Do DB Update strSql = "UPDATE " & strMemberTablePrefix & "MEMBERS " strSql = strSql & " SET M_LASTHEREDATE = '" & DateToStr(strForumTimeAdjust) & "'" strSql = strSql & ", M_LAST_IP = '" & Request.ServerVariables("REMOTE_ADDR") & "'" strSql = strSql & " WHERE " & strMemberTablePrefix & "MEMBERS." & strDBNTSQLName & " = '" & ChkString(UserName, "SQLString") & "' " my_conn.Execute (strSql) ReadLastHereDate = DateToStr(TempLastHereDate) end function function getMemberID(fUser_Name) '## Forum_SQL strSql = "SELECT " & strMemberTablePrefix & "MEMBERS.MEMBER_ID " strSql = strSql & " FROM " & strMemberTablePrefix & "MEMBERS " strSql = strSql & " WHERE " & strDBNTSQLName & " = '" & ChkString(fUser_Name, "SQLString") & "'" Set rsGetMemberID = Server.CreateObject("ADODB.Recordset") rsGetMemberID.open strSql, my_Conn getMemberID = rsGetMemberID("MEMBER_ID") rsGetMemberID.close set rsGetMemberID = nothing end function function chkDate(fDate) if fDate = "" then exit function end if ' if IsDate(fDate) then select case strDateType case "dmy" chkDate = Mid(fDate,7,2) & "/" & _ Mid(fDate,5,2) & "/" & _ Mid(fDate,1,4) case "mdy" chkDate = Mid(fDate,5,2) & "/" & _ Mid(fDate,7,2) & "/" & _ Mid(fDate,1,4) case "ymd" chkDate = Mid(fDate,1,4) & "/" & _ Mid(fDate,5,2) & "/" & _ Mid(fDate,7,2) case "ydm" chkDate =Mid(fDate,1,4) & "/" & _ Mid(fDate,7,2) & "/" & _ Mid(fDate,5,2) case "dmmy" chkDate = Mid(fDate,7,2) & " " & _ Monthname(Mid(fDate,5,2),1) & " " & _ Mid(fDate,1,4) case "mmdy" chkDate = Monthname(Mid(fDate,5,2),1) & " " & _ Mid(fDate,7,2) & " " & _ Mid(fDate,1,4) case "ymmd" chkDate = Mid(fDate,1,4) & " " & _ Monthname(Mid(fDate,5,2),1) & " " & _ Mid(fDate,7,2) case "ydmm" chkDate = Mid(fDate,1,4) & " " & _ Mid(fDate,7,2) & " " & _ Monthname(Mid(fDate,5,2),1) case "dmmmy" chkDate = Mid(fDate,7,2) & " " & _ Monthname(Mid(fDate,5,2),0) & " " & _ Mid(fDate,1,4) case "mmmdy" chkDate = Monthname(Mid(fDate,5,2),0) & " " & _ Mid(fDate,7,2) & " " & _ Mid(fDate,1,4) case "ymmmd" chkDate = Mid(fDate,1,4) & " " & _ Monthname(Mid(fDate,5,2),0) & " " & _ Mid(fDate,7,2) case "ydmmm" chkDate = Mid(fDate,1,4) & " " & _ Mid(fDate,7,2) & " " & _ Monthname(Mid(fDate,5,2),0) case else chkDate = Mid(fDate,5,2) & "/" & _ Mid(fDate,7,2) & "/" & _ Mid(fDate,1,4) End Select ' end if end function function chkTime(fTime) if fTime = "" then exit function end if if strTimeType = 12 then if cint(Mid(fTime, 9,2)) > 12 then chkTime = ChkTime & " " & _ (cint(Mid(fTime, 9,2)) -12) & ":" & _ Mid(fTime, 11,2) & ":" & _ Mid(fTime, 13,2) & " " & "PM" elseif cint(Mid(fTime, 9,2)) = 12 then chkTime = ChkTime & " " & _ cint(Mid(fTime, 9,2)) & ":" & _ Mid(fTime, 11,2) & ":" & _ Mid(fTime, 13,2) & " " & "PM" elseif cint(Mid(fTime, 9,2)) = 0 then chkTime = ChkTime & " " & _ (cint(Mid(fTime, 9,2)) +12) & ":" & _ Mid(fTime, 11,2) & ":" & _ Mid(fTime, 13,2) & " " & "AM" else chkTime = ChkTime & " " & _ Mid(fTime, 9,2) & ":" & _ Mid(fTime, 11,2) & ":" & _ Mid(fTime, 13,2) & " " & "AM" end if else ChkTime = ChkTime & " " & _ Mid(fTime, 9,2) & ":" & _ Mid(fTime, 11,2) & ":" & _ Mid(fTime, 13,2) end if end function function EmailField(fTestString) TheAt = Instr(2, fTestString, "@") if TheAt = 0 then EmailField = 0 else TheDot = Instr(cint(TheAt) + 2, fTestString, ".") if TheDot = 0 then EmailField = 0 else if cint(TheDot) + 1 > Len(fTestString) then EmailField = 0 else EmailField = -1 end if end if end if end function function chkIsNew(fDateTime) if strHotTopic = "1" then if fDateTime > Session(strCookieURL & "last_here_date") then if rs("T_REPLIES") >= intHotTopicNum then chkIsNew = "" else chkIsNew = "" end if else if rs("T_REPLIES") >= intHotTopicNum then chkIsNew = "" else chkIsNew = "" end if end if else if fDateTime > Session(strCookieURL & "last_here_date") then chkIsNew = "" else chkIsNew = "" end if end if end function Function sGetColspan(lIN, lOUT) if (strShowModerators = "1") then lOut = lOut + 1 if (mlev = "4" or mlev = "3") and (strShowModerators = "1") then lOut = lOut + 1 if (mlev = "4" or mlev = "3") and (strShowModerators <> "1") then lOut = lOut + 2 If lOut > lIn then sGetColspan = lIN Else sGetColspan = lOUT End If End Function function chkQuoteOk(fString) chkQuoteOk = not(InStr(1, fString, "'", 0) > 0) end function function chkUser(fName, fPassword) dim rsCheck dim strSql '## Forum_SQL strSql = "SELECT " & strMemberTablePrefix & "MEMBERS.MEMBER_ID, " & strMemberTablePrefix & "MEMBERS.M_LEVEL, " & strMemberTablePrefix & "MEMBERS.M_NAME, " & strMemberTablePrefix & "MEMBERS.M_PASSWORD " strSql = strSql & " FROM " & strMemberTablePrefix & "MEMBERS " strSql = strSql & " WHERE " & strMemberTablePrefix & "MEMBERS." & strDBNTSQLName & " = '" & ChkString(fName, "SQLString") & "' " if strAuthType="db" then strSql = strSql & " AND " & strMemberTablePrefix & "MEMBERS.M_PASSWORD = '" & ChkString(fPassword, "SQLString") &"'" End If strSql = strSql & " AND " & strMemberTablePrefix & "MEMBERS.M_STATUS = " & 1 Set rsCheck = my_Conn.Execute(strSql) if rsCheck.BOF or rsCheck.EOF or not(ChkQuoteOk(fName)) or not(ChkQuoteOk(fPassword)) then chkUser = 0 '## Invalid Password else select case cint(rsCheck("M_LEVEL")) case 1 chkUser = 2 '## Normal User case 2 chkUser = 3 '## Moderator case 3 chkUser = 4 '## Admin case else chkUser = cint(rsCheck("M_LEVEL")) end select end if rsCheck.close set rsCheck = nothing end function function chkUser2(fName, fPassword, fAuthor) dim rsCheck dim strSql '## Forum_SQL strSql = "SELECT " & strMemberTablePrefix & "MEMBERS.MEMBER_ID, " & strMemberTablePrefix & "MEMBERS.M_LEVEL, " & strMemberTablePrefix & "MEMBERS.M_NAME, " & strMemberTablePrefix & "MEMBERS.M_PASSWORD " strSql = strSql & " FROM " & strMemberTablePrefix & "MEMBERS " strSql = strSql & " WHERE " & strMemberTablePrefix & "MEMBERS." & strDBNTSQLName & " = '" & ChkString(fName, "SQLString") & "' " if strAuthType="db" then strSql = strSql & " AND " & strMemberTablePrefix & "MEMBERS.M_PASSWORD = '" & ChkString(fPassword, "SQLString") &"'" End If strSql = strSql & " AND " & strMemberTablePrefix & "MEMBERS.M_STATUS = " & 1 Set rsCheck = my_Conn.Execute(strSql) if rsCheck.BOF or rsCheck.EOF or not(ChkQuoteOk(fName)) or not(ChkQuoteOk(fPassword)) then chkUser2 = 0 '## Invalid Password else if (rsCheck("MEMBER_ID") & "" = fAuthor & "") and (cint(rsCheck("M_LEVEL")) <> 3) then chkUser2 = 1 '## Author else select case cint(rsCheck("M_LEVEL")) case 1 chkUser2 = 2 '## Normal User case 2 chkUser2 = 3 '## Moderator case 3 chkUser2 = 4 '## Admin case else chkUser2 = cint(rsCheck("M_LEVEL")) end select end if end if rsCheck.close set rsCheck = nothing end function function getSig(fUser_Name) '## Forum_SQL strSql = "SELECT M_SIG " strSql = strSql & " FROM " & strMemberTablePrefix & "MEMBERS " strSql = strSql & " WHERE " & strDBNTSQLName & " = '" & ChkString(Request.Form("UserName"), "SQLString") & "'" set rsSig = my_Conn.Execute (strSql) if rsSig.EOF or rsSig.BOF then '## Do Nothing else getSig = rsSig("M_SIG") end if rsSig.close set rsSig = nothing end function function doDropDown(fTableName, fDisplayField, fValueField, fSelectValue, fName) '## Forum_SQL strSql = "SELECT " & fDisplayField & ", " & fValueField strSql = strSql & " FROM " & fTableName rsdrop.Open strSql, my_Conn Response.Write "" if rsdrop.EOF or rsdrop.BOF then Response.Write "No Items Found" & vbNewline else do until rsdrop.EOF if rs(fValueField) = cint(fSelectValue) then Response.Write "" Response.Write rsdrop(fDisplayField) & "" & vbNewline else Response.Write "" Response.Write rsdrop(fDisplayField) & "" & vbNewline end if rsdrop.MoveNext loop end if Response.Write "" & vbNewline rsdrop.Close set rsdrop = nothing end function sub doULastPost(sUser_Name) '## Forum_SQL - Updates the M_LASTPOSTDATE in the FORUM_MEMBERS table strSql = "UPDATE " & strMemberTablePrefix & "MEMBERS " strSql = strSql & " SET M_LASTPOSTDATE = '" & DateToStr(strForumTimeAdjust) & "' " strSql = strSql & " WHERE " & strDBNTSQLName & " = '" & ChkString(sUser_Name, "SQLString") & "'" my_Conn.Execute (strSql) end sub '############################################## '## Ranks and Stars ## '############################################## function getMember_Level(fM_TITLE, fM_LEVEL, fM_POSTS) dim Member_Level Member_Level = "" if Trim(fM_TITLE) <> "" then Member_Level = fM_TITLE else select case fM_LEVEL case "1" if (fM_POSTS < CInt(intRankLevel1)) then Member_Level = Member_Level & strRankLevel0 if (fM_POSTS >= CInt(intRankLevel1)) and (fM_POSTS < CInt(intRankLevel2)) then Member_Level = Member_Level & strRankLevel1 if (fM_POSTS >= CInt(intRankLevel2)) and (fM_POSTS < CInt(intRankLevel3)) then Member_Level = Member_Level & strRankLevel2 if (fM_POSTS >= CInt(intRankLevel3)) and (fM_POSTS < CInt(intRankLevel4)) then Member_Level = Member_Level & strRankLevel3 if (fM_POSTS >= CInt(intRankLevel4)) and (fM_POSTS < CInt(intRankLevel5)) then Member_Level = Member_Level & strRankLevel4 if (fM_POSTS >= CInt(intRankLevel5)) then Member_Level = Member_Level & strRankLevel5 case "2" Member_Level = Member_Level & strRankMod case "3" Member_Level = Member_Level & strRankAdmin case else Member_Level = Member_Level & "Error" end select end if getMember_Level = Member_Level end function function getStar_Level(fM_LEVEL, fM_POSTS) dim Star_Level select case fM_LEVEL case "1" if (fM_POSTS < CInt(intRankLevel1)) then Star_Level = "" if (fM_POSTS >= CInt(intRankLevel1)) and (fM_POSTS < CInt(intRankLevel2)) then Star_Level = "" if (fM_POSTS >= CInt(intRankLevel2)) and (fM_POSTS < CInt(intRankLevel3)) then Star_Level = "" if (fM_POSTS >= CInt(intRankLevel3)) and (fM_POSTS < CInt(intRankLevel4)) then Star_Level = "" if (fM_POSTS >= CInt(intRankLevel4)) and (fM_POSTS < CInt(intRankLevel5)) then Star_Level = "" if (fM_POSTS >= CInt(intRankLevel5)) then Star_Level = "" case "2" if fM_POSTS < CInt(intRankLevel1) then Star_Level = "" if (fM_POSTS >= CInt(intRankLevel1)) and (fM_POSTS < CInt(intRankLevel2)) then Star_Level = "" if (fM_POSTS >= CInt(intRankLevel2)) and (fM_POSTS < CInt(intRankLevel3)) then Star_Level = "" if (fM_POSTS >= CInt(intRankLevel3)) and (fM_POSTS < CInt(intRankLevel4)) then Star_Level = "" if (fM_POSTS >= CInt(intRankLevel4)) and (fM_POSTS < CInt(intRankLevel5)) then Star_Level = "" if (fM_POSTS >= CInt(intRankLevel5)) then Star_Level = "" case "3" if (fM_POSTS < CInt(intRankLevel1)) then Star_Level = "" if (fM_POSTS >= CInt(intRankLevel1)) and (fM_POSTS < CInt(intRankLevel2)) then Star_Level = "" if (fM_POSTS >= CInt(intRankLevel2)) and (fM_POSTS < CInt(intRankLevel3)) then Star_Level = "" if (fM_POSTS >= CInt(intRankLevel3)) and (fM_POSTS < CInt(intRankLevel4)) then Star_Level = "" if (fM_POSTS >= CInt(intRankLevel4)) and (fM_POSTS < CInt(intRankLevel5)) then Star_Level = "" if (fM_POSTS >= CInt(intRankLevel5)) then Star_Level = "" case else Star_Level = "Error" end select getStar_Level = Star_Level end function '############################################## '## Multi-Moderators ## '############################################## function chkForumModerator(fForum_ID, fMember_Name) '## Forum_SQL strSql = "SELECT mo.FORUM_ID " strSql = strSql & " FROM " & strTablePrefix & "MODERATOR mo, " & strTablePrefix & "MEMBERS me " strSql = strSql & " WHERE mo.FORUM_ID = " & fForum_ID & " " strSql = strSql & " AND mo.MEMBER_ID = me.MEMBER_ID " if strAuthType = "db" then strSql = strSql & " AND me.M_NAME = '" & fMember_Name & "'" elseif strAuthType = "nt" then strSql = strSql & " AND me.M_USERNAME = '" & fMember_Name & "'" end if Set rsChk = Server.CreateObject("ADODB.Recordset") rsChk.open strSql, my_Conn if rsChk.bof or rsChk.eof then chkForumModerator = "0" else chkForumModerator = "1" end if rsChk.close set rsChk = nothing end function function listForumModerators(fForum_ID) dim strSql dim rsChk '## Forum_SQL strSql = "SELECT " & strMemberTablePrefix & "MEMBERS.M_NAME " &_ " FROM " & strTablePrefix & "MODERATOR " &_ " , " & strMemberTablePrefix & "MEMBERS " &_ " WHERE (" & strTablePrefix & "MODERATOR.FORUM_ID = " & ChkString(fForum_ID, "SQLString") & ") " &_ " AND (" & strTablePrefix & "MODERATOR.MEMBER_ID = " & strMemberTablePrefix & "MEMBERS.MEMBER_ID )" Set rsChk = Server.CreateObject("ADODB.Recordset") rsChk.open strSql, my_Conn if rsChk.EOF or not(ChkQuoteOk(fForum_ID)) then listForumModerators = "" exit function end if fMods = rsChk("M_NAME") rsChk.MoveNext do until rsChk.EOF fMods = fMods & ", " & rsChk("M_NAME") rsChk.MoveNext loop rsChk.close set rsChk = nothing listForumModerators = fMods end function function getMemberName(fUser_Number) dim strSql dim rsGetmemberName '## Forum_SQL if isNull(fUser_Number) then exit function strSql = "SELECT " & strMemberTablePrefix & "MEMBERS.M_NAME " strSql = strSql & " FROM " & strMemberTablePrefix & "MEMBERS " strSql = strSql & " WHERE MEMBER_ID = " & ChkString(fUser_Number, "SQLString") Set rsGetMemberName = Server.CreateObject("ADODB.Recordset") rsGetMemberName.open strSql, my_Conn if rsGetMemberName.EOF or rsGetMemberName.BOF then getMemberName = "" else getMemberName = rsGetMemberName("M_NAME") end if rsGetMemberName.close set rsGetMemberName = nothing end function '############################################## '## NT Authentication ## '############################################## sub NTUser() dim strSql dim rs_chk if Session(strCookieURL & "username")="" then '## Forum_SQL strSql ="SELECT " & strMemberTablePrefix & "MEMBERS.MEMBER_ID, " & strMemberTablePrefix & "MEMBERS.M_LEVEL, " & strMemberTablePrefix & "MEMBERS.M_PASSWORD, " & strMemberTablePrefix & "MEMBERS.M_USERNAME, " & strMemberTablePrefix & "MEMBERS.M_NAME " strSql = strSql & " FROM " & strMemberTablePrefix & "MEMBERS " strSql = strSql & " WHERE " & strMemberTablePrefix & "MEMBERS.M_USERNAME = '" & ChkString(Session(strCookieURL & "userid"), "SQLString") & "'" strSql = strSql & " AND " & strMemberTablePrefix & "MEMBERS.M_STATUS = " & 1 Set rs_chk = Server.CreateObject("ADODB.Recordset") rs_chk.open strSql, my_Conn if rs_chk.BOF or rs_chk.EOF then strLoginStatus = 0 else Session(strCookieURL & "username") = rs_chk("M_NAME") if strSetCookieToForum = 1 then Response.Cookies(strUniqueID & "User").Path = strCookieURL end if Response.Cookies(strUniqueID & "User")("Name") = rs_chk("M_NAME") Response.Cookies(strUniqueID & "User")("Pword") = rs_chk("M_PASSWORD") Response.Cookies(strUniqueID & "User")("Cookies") = "" Response.Cookies(strUniqueID & "User").Expires = dateAdd("d", 30, strForumTimeAdjust) Session(strCookieURL & "last_here_date") = ReadLastHereDate(Request.Form("Name")) if strAuthType = "nt" then Session(strCookieURL & "last_here_date") = ReadLastHereDate(Session(strCookieURL & "userID")) end if strLoginStatus = 1 mLev = cint(chkUser(Request.Cookies(strUniqueID & "User")("Name"), Request.Cookies(strUniqueID & "User")("Pword"))) if mLev = 4 then Session(strCookieURL & "Approval") = "15916941253" end if end if rs_chk.close set rs_chk = nothing end if end sub function chkAccountReg() dim strSql dim rs_chk '## Forum_SQL strSql ="SELECT " & strMemberTablePrefix & "MEMBERS.M_LEVEL, " & strMemberTablePrefix & "MEMBERS.M_USERNAME " strSql = strSql & " FROM " & strMemberTablePrefix & "MEMBERS " strSql = strSql & " WHERE " & strMemberTablePrefix & "MEMBERS.M_USERNAME = '" & ChkString(Session(strCookieURL & "userid"), "SQLString") & "'" strSql = strSql & " AND " & strMemberTablePrefix & "MEMBERS.M_STATUS = " & 1 Set rs_chk = Server.CreateObject("ADODB.Recordset") rs_chk.open strSql, my_Conn if rs_chk.BOF or rs_chk.EOF then chkAccountReg = "0" else chkAccountReg = "1" end if rs_chk.close set rs_chk = nothing end function sub NTAuthenticate() dim strUser, strNTUser, checkNT strNTUser = Request.ServerVariables("AUTH_USER") strNTUser = replace(strNTUser, "\", "/") if Session(strCookieURL & "userid") = "" then strUser = Mid(strNTUser,(instr(1,strNTUser,"/")+1),len(strNTUser)) Session(strCookieURL & "userid") = strUser end if if strNTGroups="1" then strNTGroupsSTR = Session(strCookieURL & "strNTGroupsSTR") if Session(strCookieURL & "strNTGroupsSTR") = "" then Set strNTUserInfo = GetObject("WinNT://"+strNTUser) For Each strNTUserInfoGroup in strNTUserInfo.Groups strNTGroupsSTR=strNTGroupsSTR+", "+strNTUserInfoGroup.name NEXT Session(strCookieURL & "strNTGroupsSTR") = strNTGroupsSTR end if end if if strAutoLogon="1" then strNTUserFullName = Session(strCookieURL & "strNTUserFullName") if Session(strCookieURL & "strNTUserFullName") = "" then Set strNTUserInfo = GetObject("WinNT://"+strNTUser) strNTUserFullName=strNTUserInfo.FullName Session(strCookieURL & "strNTUserFullName") = strNTUserFullName end if end if end sub function chkDisplayForum(fForum_ID) dim strSql dim rsAccess if (mlev = 4) then chkDisplayForum= true exit function end if '## Forum_SQL - load the user list strSql = "SELECT " & strTablePrefix & "FORUM.F_PRIVATEFORUMS, " & strTablePrefix & "FORUM.F_PASSWORD_NEW " strSql = strSql & " FROM " & strTablePrefix & "FORUM " strSql = strSql & " WHERE FORUM_ID = " & ChkString(fForum_ID, "SQLString") Set rsAccess = Server.CreateObject("ADODB.Recordset") rsAccess.open strSql, my_Conn select case rsAccess("F_PRIVATEFORUMS") case 0, 1, 2, 3, 4, 7, 9 chkDisplayForum = true rsAccess.close set rsAccess = nothing exit function case 5 UserNum = getNewMemberNumber() if UserNum = - 1 then chkDisplayForum = false rsAccess.close set rsAccess = nothing exit function else chkDisplayForum = true rsAccess.close set rsAccess = nothing exit function end if case 6 UserNum = getNewMemberNumber() if UserNum = - 1 then chkDisplayForum = false rsAccess.close set rsAccess = nothing exit function end if MatchFound = isAllowedMember(fForum_ID,UserNum) if MatchFound = 1 then chkDisplayForum = true Else chkDisplayForum = false end if case 8 chkDisplayForum = false if strAuthType ="nt" THEN NTGroupSTR = Split(strNTGroupsSTR, ", ") for j = 0 to ubound(NTGroupSTR) NTGroupDBSTR = Split(rsAccess("F_PASSWORD_NEW"), ", ") for i = 0 to ubound(NTGroupDBSTR) if NTGroupDBSTR(i) = NTGroupSTR(j) then chkDisplayForum = true rsAccess.close set rsAccess = nothing exit function end if next next End if case else chkDisplayForum= true end select rsAccess.close set rsAccess = nothing end function '############################################## '## Cookie functions and Subs ## '############################################## sub doCookies(fSavePassWord) if strSetCookieToForum = 1 then Response.Cookies(strUniqueID & "User").Path = strCookieURL else Response.Cookies(strUniqueID & "User").Path = "/" end if Response.Cookies(strUniqueID & "User")("Name") = strDBNTFUserName Response.Cookies(strUniqueID & "User")("Pword") = Request.Form("Password") Response.Cookies(strUniqueID & "User")("Cookies") = Request.Form("Cookies") if fSavePassWord = "true" then Response.Cookies(strUniqueID & "User").Expires = dateAdd("d", 30, strForumTimeAdjust) end if Session(strCookieURL & "last_here_date") = ReadLastHereDate(strDBNTFUserName) end sub sub ClearCookies() if strSetCookieToForum = 1 then Response.Cookies(strUniqueID & "User").Path = strCookieURL else Response.Cookies(strUniqueID & "User").Path = "/" end if Response.Cookies(strUniqueID & "User") = "" Session(strCookieURL & "Approval") = "" 'Response.Cookies(strUniqueID & "User").Expires = dateadd("d", -2, strForumTimeAdjust) end sub '############################################## '## Do Counts ## '############################################## sub doPCount() '## Forum_SQL - Updates the totals Table strSql ="UPDATE " & strTablePrefix & "TOTALS SET " & strTablePrefix & "TOTALS.P_COUNT = " & strTablePrefix & "TOTALS.P_COUNT + 1" my_Conn.Execute (strSql) end sub sub doTCount() '## Forum_SQL - Updates the totals Table strSql ="UPDATE " & strTablePrefix & "TOTALS SET " & strTablePrefix & "TOTALS.T_COUNT = " & strTablePrefix & "TOTALS.T_COUNT + 1" my_Conn.Execute (strSql) end sub sub doUCount(sUser_Name) '## Forum_SQL - Update Total Post for user strSql = "UPDATE " & strMemberTablePrefix & "MEMBERS " strSql = strSql & " SET " & strMemberTablePrefix & "MEMBERS.M_POSTS = " & strMemberTablePrefix & "MEMBERS.M_POSTS + 1 " strSql = strSql & " WHERE " & strDBNTSQLName & " = '" & ChkString(sUser_Name, "SQLString") & "'" my_Conn.Execute (strSql) end sub '############################################## '## Private Forums ## '############################################## sub chkUser4(pForum_ID) if mLev = 4 then exit sub end if '## Forum_SQL strSql = "SELECT " & strTablePrefix & "FORUM.F_PRIVATEFORUMS, " & strTablePrefix & "FORUM.F_SUBJECT, " & strTablePrefix & "FORUM.F_PASSWORD_NEW " strSql = strSql & " FROM " & strTablePrefix & "FORUM " strSql = strSql & " WHERE " & strTablePrefix & "FORUM.Forum_ID = " & ChkString(pForum_ID, "SQLString") Set rsStatus = Server.CreateObject("ADODB.Recordset") rsStatus.open strSql, my_Conn dim Users If cint(rsStatus("F_PRIVATEFORUMS")) <> 0 then Select case cint(rsStatus("F_PRIVATEFORUMS")) case 0 '## Do Nothing case 1, 6 '## Allowed Users UserNum = getNewMemberNumber() MatchFound = isAllowedMember(pForum_ID, cint(UserNum)) if MatchFound then rsStatus.close set rsStatus = nothing exit sub else doNotAllowed Response.end end if case 2 '## password select case Request.Cookies(strUniqueID & "User")("PRIVATE_" & rsStatus("F_SUBJECT")) case rsStatus("F_PASSWORD_NEW") '## OK case else if Request("pass") = "" then doPasswordForm Response.End else if Request("pass") <> rsStatus("F_PASSWORD_NEW") then Response.Write "Invalid password! Back" Response.End else if strSetCookieToForum = 1 then Response.Cookies(strUniqueID & "User").Path = strCookieURL end if Response.Cookies(strUniqueID & "User")("PRIVATE_" & rsStatus("F_SUBJECT")) = Request("pass") end if end if end select case 3 '## Either Password or Allowed UserNum = getNewMemberNumber() MatchFound = isAllowedMember(pForum_ID, cint(UserNum)) if MatchFound then rsStatus.close set rsStatus = nothing exit sub else select case Request.Cookies(strUniqueID & "User")("PRIVATE_" & rsStatus("F_SUBJECT")) case rsStatus("F_PASSWORD_NEW") '## OK case else if Request("pass") = "" then doLoginForm Response.End else if Request("pass") <> rsStatus("F_PASSWORD_NEW") then Response.Write "Invalid password! Back" Response.End else if strSetCookieToForum = 1 then Response.Cookies(strUniqueID & "User").Path = strCookieURL end if Response.Cookies(strUniqueID & "User")("PRIVATE_" & rsStatus("F_SUBJECT")) = Request("pass") end if end if end select end if '## code added 07/13/2000 case 7 '## members or password if (strDBNTUserName = "") then select case Request.Cookies(strUniqueID & "User")("PRIVATE_" & rsStatus("F_SUBJECT")) case rsStatus("F_PASSWORD_NEW") '## OK case else if Request("pass") = "" then doLoginForm Response.End else if Request("pass") <> rsStatus("F_PASSWORD_NEW") then Response.Write "Invalid password! Back" Response.End else if strSetCookieToForum = 1 then Response.Cookies(strUniqueID & "User").Path = strCookieURL end if Response.Cookies(strUniqueID & "User")("PRIVATE_" & rsStatus("F_SUBJECT")) = Request("pass") end if end if end select end if '## end code added 07/13/2000 case 4, 5 '## members only if strDBNTUserName = "" then doNotLoggedInForm end if case 8, 9 NTGroupSTR = Split(strNTGroupsSTR, ", ") NTGroupDBSTR = Split(rsStatus("F_PASSWORD_NEW"), ", ") For i = 0 to ubound(NTGroupDBSTR) for j = 0 to ubound(NTGroupSTR) if NTGroupDBSTR(i) = NTGroupSTR(j) then exit SUB end if next next doNotAllowed Response.end case else Response.Write "
ERROR: Invalid forum type: " & rsStatus("F_PRIVATEFORUMS") Response.end end select end if rsStatus.close set rsStatus = nothing end sub function chkForumAccess(fForum, UserNum) chkForumAccess = false strSql = "SELECT " & strMemberTablePrefix & "MEMBERS.M_LEVEL " strSql = strSql & " FROM " & strMemberTablePrefix & "MEMBERS " strSql = strSql & " WHERE " & strMemberTablePrefix & "MEMBERS.MEMBER_ID=" & UserNum Set rsCheck = Server.CreateObject("ADODB.Recordset") rsCheck.open strSql, my_Conn if rsCheck.BOF or rsCheck.EOF then chkForumAccess = false elseif rsCheck("M_LEVEL") = 3 then chkForumAccess = true rsCheck.close set rsCheck = nothing exit function end if rsCheck.close '## Forum_SQL strSql = "SELECT " & strTablePrefix & "FORUM.F_PRIVATEFORUMS, " & strTablePrefix & "FORUM.F_SUBJECT, " & strTablePrefix & "FORUM.F_PASSWORD_NEW " strSql = strSql & " FROM " & strTablePrefix & "FORUM " strSql = strSql & " WHERE " & strTablePrefix & "FORUM.Forum_ID = " & ChkString(fForum, "SQLString") Set rsStatus = Server.CreateObject("ADODB.Recordset") rsStatus.open strSql, my_Conn dim Users dim MatchFound If cint(rsStatus("F_PRIVATEFORUMS")) <> 0 then Select case cint(rsStatus("F_PRIVATEFORUMS")) case 0 chkForumAccess = true case 1, 6 '## Allowed Users chkForumAccess = (isAllowedMember(fForum,UserNum) = 1) case 2 '## password select case Request.Cookies(strUniqueID & "User")("PRIVATE_" & rsStatus("F_SUBJECT")) case rsStatus("F_PASSWORD_NEW") chkForumAccess = true case else if Request("pass") = "" then chkForumAccess = false else if Request("pass") <> rsStatus("F_PASSWORD_NEW") then chkForumAccess = false else if strSetCookieToForum = 1 then Response.Cookies(strUniqueID & "User").Path = strCookieURL end if Response.Cookies(strUniqueID & "User")("PRIVATE_" & rsStatus("F_SUBJECT")) = Request("pass") chkForumAccess = true end if end if end select case 3 '## Either Password or Allowed if isAllowedMember(fForum,UserNum) = 1 then chkForumAccess = true else chkForumAccess = false end if if not(chkForumAccess) then select case Request.Cookies(strUniqueID & "User")("PRIVATE_" & rsStatus("F_SUBJECT")) case rsStatus("F_PASSWORD_NEW") chkForumAccess = true case else if Request("pass") = "" then chkForumAccess = false else if Request("pass") <> rsStatus("F_PASSWORD_NEW") then chkForumAccess = false else if strSetCookieToForum = 1 then Response.Cookies(strUniqueID & "User").Path = strCookieURL end if Response.Cookies(strUniqueID & "User")("PRIVATE_" & rsStatus("F_SUBJECT")) = Request("pass") chkForumAccess = true end if end if end select end if '## code added 07/13/2000 case 7 '## members or password if strDBNTUserName = "" then select case Request.Cookies(strUniqueID & "User")("PRIVATE_" & rsStatus("F_SUBJECT")) case rsStatus("F_PASSWORD_NEW") chkForumAccess = true case else if Request("pass") = "" then chkForumAccess = false else if Request("pass") <> rsStatus("F_PASSWORD_NEW") then chkForumAccess = false else if strSetCookieToForum = 1 then Response.Cookies(strUniqueID & "User").Path = strCookieURL end if Response.Cookies(strUniqueID & "User")("PRIVATE_" & rsStatus("F_SUBJECT")) = Request("pass") chkForumAccess = true end if end if end select end if '## end code added 07/13/2000 case 4, 5 '## members only if Usernum = "" then chkForumAccess = false else '## V3.1 SR4 chkForumAccess = true end if case 8, 9 test="test db" chkForumAccess = FALSE if strAuthType="db" then chkForumAccess = true rsStatus.close set rsStatus = nothing exit function end if NTGroupSTR = Split(strNTGroupsSTR, ", ") for j = 0 to ubound(NTGroupSTR) NTGroupDBSTR = Split(rsStatus("F_PASSWORD_NEW"), ", ") for i = 0 to ubound(NTGroupDBSTR) if NTGroupDBSTR(i) = NTGroupSTR(j) then chkForumAccess = True rsStatus.close set rsStatus = nothing exit function end if next next case else chkForumAccess = true end select else chkForumAccess = true end if rsStatus.close set rsStatus = nothing end function sub doLoginForm() %>

There Was A Problem

You do not have access to this forum.

>If you have been given special permission by the administrator to view and/or post in this forum, enter the password here:

" id=form2 name=form2> <% for each q in Request.QueryString Response.Write "" next %>

>Go Back To Enter Data

>Return to the forum

<% WriteFooter end sub sub doNotAllowed() %>

There Was A Problem

You do not have access to this forum.

>Go Back To Enter Data

>Return to the forum

<% WriteFooter end sub sub doPasswordForm() %>

There Was A Problem

You must enter the password for this forum.

" id=form2 name=form2> <% for each q in Request.QueryString Response.Write "" next %>

>Go Back To Enter Data

>Return to the forum

<% WriteFooter end sub sub doNotLoggedInForm() %>

There was a prolbem

You must be logged in to enter this forum

>Go Back To Enter Data

>Return to the forum

<% WriteFooter Response.End end sub function getNewMemberNumber() '## Forum_SQL strSql = "SELECT " & strMemberTablePrefix & "MEMBERS.MEMBER_ID " strSql = strSql & " FROM " & strMemberTablePrefix & "MEMBERS " strSql = strSql & " WHERE " & strDBNTSQLName & " = '" & ChkString(strDBNTUserName, "SQLString") & "'" Set rsGetMemberID = Server.CreateObject("ADODB.Recordset") rsGetMemberID.open strSql, my_Conn if rsGetMemberID.EOF or rsGetMemberID.BOF then getNewMemberNumber = -1 rsGetMemberID.close set rsGetMemberID = nothing exit function end if getNewMemberNumber = rsGetMemberID("MEMBER_ID") rsGetMemberID.close set rsGetMemberID = nothing end function Function ReplaceUrls(fString) Dim oTag, c1Tag, c2Tag Dim roTag, rc1Tag, rc2Tag Dim oTagPos, c1TagPos, c2TagPos Dim nTagPos Dim counter2 Dim strArray, strArray2, strArray3 oTag = "[url=""" oTag2 = "[url]" roTag = "" c2Tag = "[/url]" rc2Tag = "" oTagPos = InStr(1, fString, oTag, 1) c1TagPos = InStr(1, fString, c1Tag, 1) strTempString = "" if (oTagpos > 0) and (c1TagPos > 0) then strArray = Split(fString, oTag, -1,1) for counter2 = 0 to UBound(strArray) if (InStr(1, strArray(counter2), c2Tag, 1) > 0) or (InStr(1, strArray(counter2), c1Tag, 1) > 0) then strArray2 = Split(strArray(counter2), c1Tag, -1,1) if Instr(1, strArray2(1), c2Tag,1) and not( (Instr(1, UCase(strArray2(1)), "[URL]",1) >0) and not(Instr(1, UCase(strArray2(1)), "[/URL]",1) >0) ) then strFirstPart = Left(strArray2(1), Instr(1, strArray2(1),c2Tag,1)-1) strSecondPart = Right(strArray2(1), (Len(strArray2(1)) - Instr(1, strArray2(1), c2Tag,1) - len(c2Tag)+1)) if strFirstPart <> "" then if (Instr(strArray2(0),"@") > 0) and UCase(Left(strArray2(0), 7)) <> "MAILTO:" then strTempString = strTempString & roTag & "mailto:" & strArray2(0) & rc1Tag & strFirstPart & rc2Tag & strSecondPart else strTempString = strTempString & roTag & strArray2(0) & rc1Tag & strFirstPart & rc2Tag & strSecondPart end if else if (Instr(strArray2(0),"@") > 0) and UCase(Left(strArray2(0), 7)) <> "MAILTO:" then strTempString = strTempString & roTag & "mailto:" & strArray2(0) & rc1Tag & strArray2(0) & rc2Tag & strSecondPart else strTempString = strTempString & roTag & strArray2(0) & rc1Tag & strArray2(0) & rc2Tag & strSecondPart end if end if else strTempString = strTempString & roTag & strArray2(0) & rc1Tag & strArray2(0) & rc2Tag & strArray2(1) end if elseif (InStr(1, strArray(counter2), c1Tag, 1) > 0) then strArray2 = Split(strArray(counter2), c1Tag, -1) strTempString = strTempString & roTag & strArray2(0) & rc1Tag & strArray2(0) & rc2Tag & strArray2(1) else strTempString = strTempString & strArray(counter2) end if next else strTempString = fString end if oTagPos2 = InStr(1, strTempString, oTag2, 1) c1TagPos2 = InStr(1, strTempString, c1Tag2, 1) if (oTagpos2 > 0) and (c1TagPos2 > 0) then strTempString2 = "" strArray = Split(strTempString, oTag2, -1,1) for counter3 = 0 to Ubound(strArray) if (Instr(1, strArray(counter3), c1Tag2,1) > 0) then strArray2 = split(strArray(counter3), c1Tag2, -1,1) if (Instr(strArray2(0),"@") > 0) and UCase(Left(strArray2(0), 7)) <> "MAILTO:" then strTempString2 = strTempString2 & roTag & "mailto:" & strArray2(0) & rc1Tag & strArray2(0) & rc2Tag & strArray2(1) else strTempString2 = strTempString2 & roTag & strArray2(0) & rc1Tag & strArray2(0) & rc2Tag & strArray2(1) end if else strTempString2 = strTempString2 & strArray(counter3) end if next strTempString = strTempString2 end if ReplaceUrls = strTempString end function function isAllowedMember(fForum_ID,fMemberID) isAllowedMember = 0 on error resume next strSql = "SELECT MEMBER_ID, FORUM_ID FROM " & strTablePrefix & "ALLOWED_MEMBERS " strSql = strSql & " WHERE " & strTablePrefix & "ALLOWED_MEMBERS.FORUM_ID = " & ChkString(fForum_ID, "SQLString") strSql = strSql & " AND " & strTablePrefix & "ALLOWED_MEMBERS.MEMBER_ID = " & ChkString(fMemberID, "SQLString") Set rsAllowedMember = Server.CreateObject("ADODB.Recordset") rsAllowedMember.open strSql, my_Conn if (rsAllowedMember.EOF or rsAllowedMember.BOF) then isAllowedMember = 0 rsAllowedMember.close set rsAllowedMember = nothing exit function else isAllowedMember = 1 rsAllowedMember.close set rsAllowedMember = nothing end if end function Function SetConfigValue(bUpdate, fVariable, fValue) ' bUpdate = 1 : if it exists then overwrite with new values ' bUpdate = 0 : if it exists then leave unchanged Dim strSql strSql = "SELECT C_VARIABLE FROM " & strTablePrefix & "CONFIG_NEW " &_ " WHERE C_VARIABLE = '" & fVariable & "' " Set rs = Server.CreateObject("ADODB.Recordset") rs.open strSql, my_Conn if (rs.EOF or rs.BOF) then '## New config-value SetConfigValue = "added" my_conn.execute ("INSERT INTO " & strTablePrefix & "CONFIG_NEW (C_VALUE,C_VARIABLE) VALUES ('" & fValue & "' , '" & fVariable & "')") else if bUpdate <> 0 then SetConfigValue = "updated" my_conn.execute ("UPDATE " & strTablePrefix & "CONFIG_NEW SET C_VALUE = '" & fValue & "' WHERE C_VARIABLE = '" & fVariable &"'") else ' not changed SetConfigValue = "unchanged" end if end if rs.close set rs = nothing end function Function ReplaceImageTags(fString) Dim oTag, cTag Dim roTag, rcTag Dim oTagPos, cTagPos Dim nTagPos Dim counter1, counter2 Dim strUrlText Dim Tagcount Dim strTempString, strResultString TagCount = 6 Dim ImgTags(6,2,2) Dim strArray, strArray2 ImgTags(1,1,1) = "[img]" ImgTags(1,2,1) = "[/img]" ImgTags(1,1,2) = "" ImgTags(2,1,1) = "[image]" ImgTags(2,2,1) = "[/image]" ImgTags(2,1,2) = ImgTags(1,1,2) ImgTags(2,2,2) = ImgTags(1,2,2) ImgTags(3,1,1) = "[img=right]" ImgTags(3,2,1) = "[/img=right]" ImgTags(3,1,2) = "" ImgTags(4,1,1) = "[image=right]" ImgTags(4,2,1) = "[/image=right]" ImgTags(4,1,2) = ImgTags(3,1,2) ImgTags(4,2,2) = ImgTags(3,2,2) ImgTags(5,1,1) = "[img=left]" ImgTags(5,2,1) = "[/img=left]" ImgTags(5,1,2) = "" ImgTags(6,1,1) = "[image=left]" ImgTags(6,2,1) = "[/image=left]" ImgTags(6,1,2) = ImgTags(5,1,2) ImgTags(6,2,2) = ImgTags(5,2,2) strResultString = "" strTempString = fString for counter1 = 1 to TagCount oTag = ImgTags(counter1,1,1) roTag = ImgTags(counter1,1,2) cTag = ImgTags(counter1,2,1) rcTag = ImgTags(counter1,2,2) oTagPos = InStr(1, strTempString, oTag, 1) cTagPos = InStr(1, strTempString, cTag, 1) if (oTagpos > 0) and (cTagPos > 0) then strArray = Split(strTempString, oTag, -1) for counter2 = 0 to Ubound(strArray) if (Instr(1, strArray(counter2), cTag) > 0) then strArray2 = split(strArray(counter2), cTag, -1) strUrlText = strArray2(0) strUrlText = replace(strUrlText, """", "") ' ## filter out " strUrlText = replace(strUrlText, "<", "") ' ## filter out < strUrlText = replace(strUrlText, ">", "") ' ## filter out > strResultString = strResultString & roTag & strUrlText & rcTag & strArray2(1) else strResultString = strResultString & strArray(counter2) end if next strTempString = strResultString strResultString = "" end if next ReplaceImageTags = strTempString end function function getMemberNumber(fUser_Name) '## Forum_SQL strSql = "SELECT " & strMemberTablePrefix & "MEMBERS.MEMBER_ID " strSql = strSql & " FROM " & strMemberTablePrefix & "MEMBERS " strSql = strSql & " WHERE " & strDBNTSQLName & " = '" & fUser_Name & "'" Set rsGetMemberNumber = Server.CreateObject("ADODB.Recordset") rsGetMemberNumber.open strSql, my_Conn if rsGetMemberNumber.EOF or rsGetMemberNumber.BOF then getMemberNumber = -1 rsGetMemberNumber.close set rsGetMemberNumber = nothing exit function end if getMemberNumber = rsGetMemberNumber("MEMBER_ID") rsGetMemberNumber.close set rsGetMemberNumber = nothing end function Function IsValidString(sValidate) Dim sInvalidChars Dim bTemp Dim i ' Disallowed characters sInvalidChars = "!#$%^&*()=+{}[]|\;:/?>,<" For i = 1 To Len(sInvalidChars) If InStr(sValidate, Mid(sInvalidChars, i, 1)) > 0 _ Then bTemp = True If bTemp Then Exit For Next For i = 1 To Len(sValidate) If Asc(Mid(sValidate, i, 1)) = 160 _ Then bTemp = True If bTemp Then Exit For Next ' extra checks ' no two consecutive dots or spaces if not bTemp then bTemp = InStr(sValidate, "..") > 0 end if if not bTemp then bTemp = InStr(sValidate, " ") > 0 end if if not bTemp then bTemp = (len(sValidate) <> len(Trim(sValidate))) end if 'Addition for leading and trailing spaces ' if any of the above are true, invalid string IsValidString = Not bTemp End Function Sub WriteFooter() %> <% end sub %>