<%Response.Buffer = True On Error Resume Next '### DO NOT MODIFY THIS SECTION! ### '========================================================================================================================== Dim key, dbFolder, imgLocation, upload, logo, adminkey, verify_user, moderate, bnrLocation, mysql, mssql, msaccess Dim objFile, catFolder, logFolder, logPATH, dbPATH, catPATH, emailMethod, admin_email, mailHost, notify_email, isIE Dim htextcolor, maxChr, s, sf, sg, ss, web_site, web_name, pp, SMTPID, SMTPPAss, rFile, largeimage, catpos, timeOffset Dim isnotfree, uOpt(7), uOptD(7), strConn, rs, advArray(28), ppArray(30), resetLocale, server_locale, Wysiwyg_type Dim meta_description, meta_keywords, detectMultipleIP, scr_Name, result_web_name, result_meta_description, imagelimit Dim result_meta_keywords, full_description, default_to_cat, ad_cache, IsCache, uOptType(6), uOptSearch(6), optCatList Dim cat3rdName, catName, subCatName, isTurningNumber, seclog, isEvents, eventsArray(21), ispack, istn, listalpha Dim tablPfx, tablUPfx, strUnique, strSUnique, rcver, IP, Sess_Array(100), objConn, uagent, adminPage, isXLT, cfg_reply, cfg_view IP = Request.ServerVariables("REMOTE_ADDR") If Len(Request.ServerVariables("HTTP_X_FORWARDED_FOR")) > 0 Then IP = Request.ServerVariables("HTTP_X_FORWARDED_FOR") uagent = Request.ServerVariables("HTTP_USER_AGENT") '========================================================================================================================== '************************************************************************************************************************** '******************************** START CONFIGURATION ********************************************** '************************************************************************************************************************** '### SECURITY ### ' Display admin menu on all administation pages. Replace [True] with [False] to hide. showAdminMenu = True ' Display "Admin" link within the general menu at the top navigation bar. Replace [True] with [False] to hide. showAdminLink = True ' Admin Logon page name. After changing this value, make sure to rename current admin logon page reflecting the change. ' This variable only reflects the page name. Physical page should always have .asp extention. adminPage = "admin_logon" '### SELECT CLIENT LOCALE ### setLocale "1033" '========================================================================================================================== '### SELECT TIME OFFSET (Difference between server time and your location time. Can be positive or negative number.) ### timeOffset = 0 '========================================================================================================================== '### CHANGE FOLLOWING VALUES TO REFLECT THE CORRECT PATH TO FOLDERS ### dbFolder = "db/" upload = "cl_upload/" bnrLocation = "banners/" ad_cache = "ads/" logo = "img/logo.png" '========================================================================================================================== '### SELECT DATABASE TYPE ### databaseType = "msaccess" 'databaseType = "mssql" 'databaseType = "mysql" '========================================================================================================================== '### CONNECTION STRINGS CONFIGURATION ### Select Case databaseType '*** ACCESS DATABASE *** Case "msaccess" msaccess = True strConn = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" strConn = strConn & Server.MapPath(dbFolder & "cldb.mdb") & ";" '*** MSSQL DATABASE *** Case "mssql" Dim SQLServer mssql = true '# SQL SERVER NAME (PROVIDED BY YOUR HOST) SQLServer = "server_name/IP" '# SQL USER ID (AUTHENTICATION) SQLUser = "user_name" '# SQL PASSWORD (AUTHENTICATION) SQLPassword = "password" '# SQL DATABASE NAME SQLDBName = "database_name" '# DO NOT MODIFY THE CONNECTION STRING BELOW!!!! FOR EXPERIENCED DEVELOPERS ONLY!!! '# If you are an experienced developer and choose to modify connection string for one reason or another, '# make sure to change the respective connection string in mssql_tbl_setup.asp strConn = "Provider=SQLOLEDB;Server=" & SQLServer strConn = strConn & ";User ID=" & SQLUser strConn = strConn & ";Password=" & SQLPassword strConn = strConn & ";Database=" & SQLDBName & ";" '*** MySQL DATABASE *** Case "mysql" Dim MySQLServer mysql = true '# MySQL SERVER IP ADDRESS (PROVIDED BY YOUR HOST) MySQLServer = "server_name/IP" '# MySQL USER ID (AUTHENTICATION) MySQLUser = "user_name" '# MySQL PASSWORD (AUTHENTICATION) MySQLPassword = "password" '# MySQL DATABASE NAME MySQLDBName = "database_name" '# DO NOT MODIFY THE CONNECTION STRING BELOW!!!! FOR EXPERIENCED DEVELOPERS ONLY!!! '# If you are an experienced developer and choose to modify connection string for one reason or another, '# make sure to change the respective connection string in mysql_tbl_setup.asp strConn = "Driver={MySQL ODBC 3.51 Driver};server=" & MySQLServer strConn = strConn & ";uid=" & MySQLUser strConn = strConn & ";pwd=" & MySQLPassword strConn = strConn & ";database=" & MySQLDBName & ";" End Select '************************************************************************************************************************** '******************************** END CONFIGURATION ********************************************** '************************************************************************************************************************** Set objConn = Server.CreateObject("ADODB.Connection") objConn.CursorLocation = 3 objConn.open strConn resetLocale = getLocale server_locale = "1033" 'DO NOT MODIFY THIS s = chr(15) sf = chr(166) sg = chr(164) ss = chr(14) %><% tablPfx = "tbl" tablUPfx = "tbl" strUnique = "_v32c" strSUnique = "_v32c" %><% rcver = 323 AuthorizeNetInstalled = False %> <% Function getTemplate(template, uEmail, uPass, uNick, verID, adID) setLocale resetLocale strTempl = "SELECT " & tablPfx & "Template.* from " & tablPfx & "Template WHERE tname='" & sq(template) & "';" set rsTempl = objConn.Execute(strTempl) If not rsTempl.EOF then templRec = rsTempl("subject") & chr(15) & rsTempl("body") templRec = Replace(templRec, ":uEmail:", uEmail) templRec = Replace(templRec, ":uPass:", uPass) templRec = Replace(templRec, ":uNick:", uNick) templRec = Replace(templRec, ":verID:", verID) templRec = Replace(templRec, ":Date:", Now) templRec = Replace(templRec, ":adID:", adID) templRec = Replace(templRec, ":MyWeb:", web_site) templRec = Replace(templRec, ":WebNm:", web_name) uSubject = Split(templRec, chr(15))(0) uBody = Split(templRec, chr(15))(1) getTemplate = templRec End If rsTempl.close End Function Sub sendEmail(sendTo, sendFrom, subject, message) Select Case emailMethod '### Email with CDOSYS (http://www.microsoft.com) Case "CDOSYS" On Error Resume Next Set objCDOSYSMail = Server.CreateObject("CDO.Message") If not mailHost = Empty then Set objCDOSYSCon = Server.CreateObject ("CDO.Configuration") With objCDOSYSCon .Fields("http://schemas.microsoft.com/cdo/configuration/smtpserver") = mailHost .Fields("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25 .Fields("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2 .Fields("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = 60 If not SMTPID = Empty then .Fields("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1 .Fields("http://schemas.microsoft.com/cdo/configuration/sendusername") = SMTPID .Fields("http://schemas.microsoft.com/cdo/configuration/sendpassword") = SMTPPAss End If .Fields.Update End With Set objCDOSYSMail.Configuration = objCDOSYSCon End If With objCDOSYSMail .From = "<" & sendFrom & ">" .Sender = sendFrom If len(senderEmail) > 0 Then .ReplyTo = senderEmail '.BodyPart.CharSet = "Windows-1252" '.HTMLBodyPart.charset = "Windows-1252" .To = "<" & sendTo & ">" .Subject = subject If isHTML then .HTMLBody = message Else: .TextBody = message End If .Send End With Set objCDOSYSMail = Nothing On Error Goto 0 '### Email with CDONTS (http://www.microsoft.com) Case "CDONTS" On Error Resume Next Set oEmail = Server.CreateObject("CDONTS.NewMail") With oEmail .From = sendFrom .To = sendTo .Subject = subject If isHTML then .MailFormat = 0 Else: .MailFormat = 1 End If .BodyFormat = 0 .Body = message .Importance = 1 '.SetLocaleIDs("Windows-1252") .Send Set oEmail = Nothing End With On Error Goto 0 '### Email with ASPmail (http://www.serverobjects.com) Case "ASPMail" On Error Resume Next Set Mailer = Server.CreateObject("SMTPsvg.Mailer") With Mailer .FromName = sendFrom .FromAddress = sendFrom .RemoteHost = mailHost .AddRecipient "Classified User", sendTo If len(senderEmail) > 0 Then .ReplyTo = senderEmail .ReturnReceipt = false .ConfirmRead = false .Subject = subject '.CustomCharSet = "Windows-1252" If isHTML then .ContentType = "text/html" .BodyText = message .SendMail End With Set Mailer = Nothing On Error Goto 0 '### Email with ASPEmail (http://www.aspemail.com) Case "ASPEmail" On Error Resume Next Set Mailer = Server.CreateObject("Persits.MailSender") With Mailer .FromName = sendFrom .From = sendFrom .Host = mailHost .AddAddress sendTo, "Classified User" If len(senderEmail) > 0 Then .AddReplyTo = senderEmail .Subject = subject If isHTML then .IsHTML = True .Body = message If not SMTPID = Empty then .Username = SMTPID .Password = SMTPPass End If '.CharSet = "Windows-1252" '.ContentTransferEncoding = "Quoted-Printable" .Send End With Set Mailer = Nothing On Error Goto 0 '### Email with Jmail (http://www.dimac.net/) Case "JMail" On Error Resume Next Set jmail = Server.CreateObject("JMail.Message") With jmail .Logging = False .Silent = True .AddRecipient sendTo, "Classified User" .FromName = sendFrom .From = sendFrom If len(senderEmail) > 0 Then .ReplyTo = senderEmail .Subject = subject If isHTML then .HTMLBody = message Else: .Body = message End If .Priority = 3 If not SMTPID = Empty then .MailServerUserName = SMTPID .MailServerPassWord = SMTPPass End If '.CharSet = "Windows-1252" .Send(mailHost) End With Set jmail = Nothing On Error Goto 0 End Select End Sub %> <%Function CryptText(strIn, fubarKey, action) Select Case action Case False For n = 1 To Len( strIn ) Step 3 c1 = Asc( Mid( strIn, n, 1 ) ) c2 = Asc( Mid( strIn, n + 1, 1 ) + Chr(0) ) c3 = Asc( Mid( strIn, n + 2, 1 ) + Chr(0) ) w1 = Int( c1 / 4 ) : w2 = ( c1 And 3 ) * 16 + Int( c2 / 16 ) If Len( strIn ) >= n + 1 Then w3 = ( c2 And 15 ) * 4 + Int( c3 / 64 ) Else w3 = -1 End If If Len( strIn ) >= n + 2 Then w4 = c3 And 63 Else w4 = -1 End If strOut = strOut + mimeencode( w1 ) + mimeencode( w2 ) + _ mimeencode( w3 ) + mimeencode( w4 ) Next CryptText = strOut Case True For n = 1 To Len( strIn ) Step 4 w1 = mimedecode( Mid( strIn, n, 1 ) ) w2 = mimedecode( Mid( strIn, n + 1, 1 ) ) w3 = mimedecode( Mid( strIn, n + 2, 1 ) ) w4 = mimedecode( Mid( strIn, n + 3, 1 ) ) If w2 >= 0 Then _ strOut = strOut + _ Chr( ( ( w1 * 4 + Int( w2 / 16 ) ) And 255 ) ) If w3 >= 0 Then _ strOut = strOut + _ Chr( ( ( w2 * 16 + Int( w3 / 4 ) ) And 255 ) ) If w4 >= 0 Then _ strOut = strOut + _ Chr( ( ( w3 * 64 + w4 ) And 255 ) ) Next CryptText = strOut End Select End Function Function mimedecode(strIn) Base64Chars = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" If Len( strIn ) = 0 Then mimedecode = -1 : Exit Function Else mimedecode = InStr( Base64Chars, strIn ) - 1 End If End Function Function mimeencode(intIn) Base64Chars = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" If intIn >= 0 Then mimeencode = Mid( Base64Chars, intIn + 1, 1 ) Else mimeencode = "" End If End Function %> <% Sub checkLoggedUser() On Error Resume Next Sess_Array(34) = 1 If Len(Request.Cookies("amazing_scenery" & strUnique)) > 0 then uID = CryptText(Request.Cookies("amazing_scenery" & strUnique), key, True) If IsNumeric(uID) then set rsuser = objConn.Execute("SELECT " & tablUPfx & "User.* FROM " & tablUPfx & "User WHERE userID = " & CLng(uID) & ";") If not rsuser.EOF then acountStatus = CLng(rsuser("status")) Select Case acountStatus Case 0 sdd = dd(objConn) ismod = rsuser("moder") If ismod then Sess_Array(35) = 1 Sess_Array(29) = CLng(uID) Sess_Array(50) = CryptText(rsuser("email"), key, True) Sess_Array(51) = rsuser("nick") Sess_Array(49) = rsuser("city") setLocale server_locale Sess_Array(47) = FormatNumber(CCur(rsuser("credits")), 2) setLocale resetLocale If ispack then Sess_Array(30) = Empty Sess_Array(61) = Empty Sess_Array(59) = Empty Sess_Array(30) = CLng(rsuser("paypack")) Sess_Array(61) = CDate(rsuser("pexpire")) ishold = Cbool(rsuser("ishold")) If Sess_Array(30) > 0 then Set rspack = objConn.Execute("SELECT pname,pdur,custom1 FROM " & tablPfx & "Pack WHERE packID = " & Sess_Array(30) & ";") If rspack.EOF then Sess_Array(30) = 0 rspack.close Else pdur = rspack(1) currpname = rspack(0) isdefault = rspack(2) rspack.close If ishold then Sess_Array(59) = currpname Sess_Array(61) = DateAdd("d", pdur, Now) packExp = ConvDate(Sess_Array(61)) objConn.Execute("UPDATE " & tablUPfx & "User SET pexpire = " & sdd & packExp & sdd & ", ishold = 0 WHERE userID = " & uID & ";") Else If Sess_Array(61) < Now then If CLng(isdefault) = 1 then If Sess_Array(30) = 1000 then pexp = DateAdd("d", CDate(pdur), Now) trpname = currpname Else Sess_Array(30) = 1000 Set rstr = objConn.Execute("SELECT pname,pdur FROM " & tablPfx & "Pack WHERE packID = 1000;") trpname = rstr(0) trpdur = rstr(1) rstr.close pexp = DateAdd("d", CDate(trpdur), Now) End If pexp = ConvDate(pexp) objConn.Execute("UPDATE " & tablUPfx & "User SET paypack = 1000, pexpire = " & sdd & pexp & sdd & " WHERE userID = " & uID & ";") template = getTemplate("Package_Default", Sess_Array(50), Empty, Sess_Array(51), Empty, Empty) TemplateArray = Split(template, s) uSubject = TemplateArray(0) uBody = TemplateArray(1) uBody = Replace(uBody, ":adCred:", trpname) Call sendEmail(Sess_Array(50), notify_email, uSubject, uBody) Sess_Array(59) = trpname Sess_Array(61) = CDate(pexp) Else Sess_Array(30) = 0 objConn.Execute("UPDATE " & tablUPfx & "User SET paypack = 0 WHERE userID = " & uID & ";") End If emailContent = getTemplate("Package_Expire", Sess_Array(50), Empty, Sess_Array(51), Empty, Empty) uSubject = Split(emailContent, s)(0) uBody = Split(emailContent, s)(1) uBody = Replace(uBody, ":adCred:", currpname) Call sendEmail(Sess_Array(50), notify_email, uSubject, uBody) Else: Sess_Array(59) = currpname End If End If End If End If End If set rsstat = objConn.Execute("SELECT ID FROM " & tablPfx & "Ads WHERE userID = " & CLng(uID) & ";") If not rsstat.EOF then rsdata = rsstat.getrows myads = UBound(rsdata,2) + 1 Else: myads = 0 End If rsstat.close Sess_Array(28) = myads If not Sess_Array(48) = Session.SessionID then updateIP = ", IP = '" & IP & "' " objConn.Execute("UPDATE " & tablUPfx & "User SET lastLogon = " & sdd & ConvDate(Now) & sdd & updateIP & ", ads = " & myads & " WHERE userID = " & CLng(uID) & ";") If not Sess_Array(48) = Session.SessionID then Call checkIP(IP) If isEvents then Call logEvent("User Logon", "(From Cookies)", Empty, Empty, Empty, Empty) Case Else Response.Cookies("amazing_scenery" & strUnique).Expires = Now - 1 End Select End If rsuser.close End If End If End Sub %> <% Dim RSS_Items Dim RSS_ShowDefaultTitle Dim RSS_CustomTitle Dim RSS_ShowLogo Dim RSS_ShowBullets Dim RSS_ShowItemPostDate Dim RSS_ShowItemDescription Dim RSS_DisplayInRCBox Dim RSS_TitleFontSize Dim RSS_SubjectFontSize Dim RSS_DescriptionFontSize Dim RSS_BulletsImage Dim RSS_LinksNewWindow Dim RSS_UseItemsSeparator Dim RSS_ShowEnclosure Dim RSS_Custom1 Dim RSS_Custom2 Dim RSS_Custom3 Dim RSS_Custom4 Dim RSS_Custom5 Dim RSS_Custom6 Dim RSS_Custom7 Dim RSS_Custom8 Dim RSS_Custom9 Dim RSS_Custom10 Dim RSS Function Format_RSS() If Len(preview_Feed) > 0 then RSS_Link = Request.Form("RSS_Link") RSS_Items = CLng(Request.Form("RSS_Items")) RSS_ShowDefaultTitle = CBool(Request.Form("RSS_ShowDefaultTitle")) RSS_CustomTitle = Request.Form("RSS_CustomTitle") RSS_ShowLogo = CBool(Request.Form("RSS_ShowLogo")) RSS_ShowBullets = CBool(Request.Form("RSS_ShowBullets")) RSS_ShowItemPostDate = CBool(Request.Form("RSS_ShowItemPostDate")) RSS_ShowItemDescription = CBool(Request.Form("RSS_ShowItemDescription")) RSS_DisplayInRCBox = CBool(Request.Form("RSS_DisplayInRCBox")) RSS_TitleFontSize = Request.Form("RSS_TitleFontSize") RSS_SubjectFontSize = Request.Form("RSS_SubjectFontSize") RSS_DescriptionFontSize = Request.Form("RSS_DescriptionFontSize") RSS_BulletsImage = Request.Form("RSS_BulletsImage") RSS_LinksNewWindow = CBool(Request.Form("RSS_LinksNewWindow")) RSS_UseItemsSeparator = CBool(Request.Form("RSS_UseItemsSeparator")) RSS_ShowEnclosure = CBool(Request.Form("RSS_ShowEnclosure")) RSS_Custom1 = Request.Form("RSS_Custom1") RSS_Custom2 = Request.Form("RSS_Custom2") RSS_Custom7 = CBool(Request.Form("RSS_Custom7")) Set RSS = new kwRSS_reader RSS.ParseLocation(RSS_Link) RSS_Status = RSS.GetStatus If RSS_Status <> 0 then Response.Write "Feed is not available" End If Set rebr = new RegExp rebr.global=true rebr.ignoreCase=true rebr.pattern="((\S){100})" RSS_ChannelTitle = RSS.ChannelTitle RSS_ChannelTitle = rebr.replace(RSS_ChannelTitle, "$1
") RSS_ChannelLanguage = RSS.ChannelLanguage RSS_ChannelURL = RSS.ChannelURL RSS_ChannelDesc = RSS.ChannelDesc RSS_ChannelDesc = rebr.replace(RSS_ChannelDesc, "$1
") RSS_ImageURL = RSS.ImageURL RSS_ChannelCategory = RSS.ChannelCategory RSS_ChannelCategory = rebr.replace(RSS_ChannelCategory, "$1
") If RSS_LinksNewWindow then newWindow = "target='_blank'" If RSS_UseItemsSeparator then itemsSep = "style='border-bottom: 1px dotted #C0C0C0;'" '*** Begin Box Table If RSS_DisplayInRCBox then RSS_OUT = RSS_OUT & "
" RSS_OUT = RSS_OUT & "" RSS_OUT = RSS_OUT & "" RSS_OUT = RSS_OUT & "" RSS_OUT = RSS_OUT & "" RSS_OUT = RSS_OUT & "" RSS_OUT = RSS_OUT & "
" End If If RSS_ShowDefaultTitle OR RSS_ShowLogo OR Len(RSS_CustomTitle) > 0 then '*** Begin Title Table RSS_OUT = RSS_OUT & "
" '*** Display Feed Title/Description/Category RSS_OUT = RSS_OUT & "" Else RSS_OUT = RSS_OUT & RSS_CustomTitle & "" & RSS_ChannelCategory_Display & "" End If '*** Display Feed Logo Image If RSS_ShowLogo And Len(RSS_ImageURL) > 0 then RSS_OUT = RSS_OUT & "" Else RSS_OUT = RSS_OUT & "" End If RSS_OUT = RSS_OUT & "

" & RSS_ChannelDesc & RSS_ChannelCategory_Display & "
" '*** End Title Table End If '*** Begin Items Table RSS_OUT = RSS_OUT & "
" na = 1 Do While Not RSS.EOF If na > RSS_Items then Exit Do RSS_OUT = RSS_OUT & "" If na mod 2 = 0 then cellColor = "class='evencell'": Else: cellColor = "class='oddcell'" If RSS_ShowBullets then RSS_OUT = RSS_OUT & "" End If RSS_GetDesc = RSS.GetDesc RSS_GetDesc = rebr.replace(RSS_GetDesc, "$1
") RSS_GetTitle = RSS.GetTitle RSS_GetTitle = rebr.replace(RSS_GetTitle, "$1
") RSS_GetDate = RSS.GetDate RSS_GetLink = RSS.GetLink RSS_GetEnclosure = RSS.GetEnclosure RSS_GetCategory = RSS.GetCategory strEncImage = Empty If RSS_ShowEnclosure And Len(RSS_GetEnclosure) > 0 then strSize = Empty If Len(RSS_Custom1) > 1 then iWidth = Split(RSS_Custom1, "x")(0) iHeight = Split(RSS_Custom1, "x")(1) strSize = "width=" & iWidth & " height=" & iHeight End If If RSS_Custom2 = "none" then strAlign = Empty Else strAlign = "align='" & RSS_Custom2 & "'" End If strEncImage = "" End If RSS_OUT = RSS_OUT & "" & vbcrlf na = na + 1 RSS.MoveNext Loop RSS_OUT = RSS_OUT & "
" If RSS_ShowItemPostDate And Len(RSS_GetDate) > 0 then RSS_OUT = RSS_OUT & "
" & RSS_GetDate & "
" If RSS_Custom7 And Len(RSS_GetCategory) > 0 then RSS_OUT = RSS_OUT & "
Category: " & RSS_GetCategory & "
" If RSS_ShowItemDescription then RSS_OUT = RSS_OUT & "
" & strEncImage & RSS_GetDesc & "
" If RSS_ShowEnclosure And Not RSS_ShowItemDescription then RSS_OUT = RSS_OUT & strEncImage RSS_OUT = RSS_OUT & "
" '*** End Items Table If RSS_DisplayInRCBox then RSS_OUT = RSS_OUT & "
" End If '*** End Box Table Set RSS = Nothing Set rebr = Nothing Format_RSS = RSS_OUT End Function Sub Cache_Feed(feedID) strSQL = "SELECT ID,feed_date_cache,RSS_Link,RSS_CacheAge," strSQL = strSQL & "RSS_Items,RSS_ShowDefaultTitle,RSS_CustomTitle,RSS_ShowLogo," strSQL = strSQL & "RSS_ShowBullets,RSS_ShowItemPostDate,RSS_ShowItemDescription,RSS_DisplayInRCBox," strSQL = strSQL & "RSS_TitleFontSize,RSS_SubjectFontSize,RSS_DescriptionFontSize,RSS_BulletsImage," strSQL = strSQL & "RSS_LinksNewWindow,RSS_UseItemsSeparator,RSS_ShowEnclosure,RSS_Custom1,RSS_Custom2,RSS_Custom7" strSQL = strSQL & " FROM " & tablPfx & "RSS WHERE ID = " & CLng(feedID) & ";" Set rsfeed = objConn.Execute(strSQL) If Not rsfeed.EOF then feed_data_array = rsfeed.getrows Feed_Exists = True End If rsfeed.close If Feed_Exists then currentFeedID = feed_data_array(0,0) feed_date_cache = feed_data_array(1,0) RSS_Link = feed_data_array(2,0) RSS_CacheAge = CLng(feed_data_array(3,0)) RSS_Items = CLng(feed_data_array(4,0)) RSS_ShowDefaultTitle = CBool(feed_data_array(5,0)) RSS_CustomTitle = feed_data_array(6,0) RSS_ShowLogo = CBool(feed_data_array(7,0)) RSS_ShowBullets = CBool(feed_data_array(8,0)) RSS_ShowItemPostDate = CBool(feed_data_array(9,0)) RSS_ShowItemDescription = CBool(feed_data_array(10,0)) RSS_DisplayInRCBox = CBool(feed_data_array(11,0)) RSS_TitleFontSize = feed_data_array(12,0) RSS_SubjectFontSize = feed_data_array(13,0) RSS_DescriptionFontSize = feed_data_array(14,0) RSS_BulletsImage = feed_data_array(15,0) RSS_LinksNewWindow = CBool(feed_data_array(16,0)) RSS_UseItemsSeparator = CBool(feed_data_array(17,0)) RSS_ShowEnclosure = CBool(feed_data_array(18,0)) RSS_Custom1 = feed_data_array(19,0) RSS_Custom2 = feed_data_array(20,0) RSS_Custom7 = CBool(feed_data_array(21,0)) Erase feed_data_array Set RSS = new kwRSS_reader RSS.ParseLocation(RSS_Link) RSS_Status = RSS.GetStatus If RSS_Status = 0 then feed_data = Format_RSS() feed_data = sq(feed_data) If Len(feed_data) > 300 then sdd = dd(objConn) objConn.Execute("UPDATE " & tablPfx & "RSS SET feed_data = '" & feed_data & "',feed_date_cache = " & sdd & ConvDate(Now) & sdd & " WHERE ID=" & CLng(feedID) & ";") Else: objConn.Execute("UPDATE " & tablPfx & "RSS SET feed_date_cache = " & sdd & ConvDate(Now) & sdd & " WHERE ID=" & CLng(feedID) & ";") End If End If End If End Sub Function Build_RSS(base_string) On Error Resume Next Set re = New RegExp re.Global = True re.IgnoreCase = True re.Pattern = ":RSS=(\S+):" If re.test(base_string) then Set rss_matches = re.execute(base_string) For each match in rss_matches replstring = match.value rssfeed = match.SubMatches(0) base_string = Replace(base_string, replstring, Display_RSS(rssfeed)) Next End If re.Pattern = ":RotateBanner=(\d+):" If re.test(base_string) then Set zone_matches = re.execute(base_string) For each match in zone_matches replstring = match.value izone = match.SubMatches(0) base_string = Replace(base_string, replstring, RotateBanner(izone)) Next End If Set re = Nothing Build_RSS = base_string On error Goto 0 End Function Function Display_RSS(rssfeed) Set rsnewfeed = objConn.Execute("SELECT feed_data,feed_date_cache,RSS_CacheAge,ID FROM " & tablPfx & "RSS WHERE feed_name = '" & sq(rssfeed) & "';") If NOT rsnewfeed.EOF then Display_RSS = rsnewfeed(0) feed_date_cache = rsnewfeed(1) RSS_CacheAge = CLng(rsnewfeed(2)) ID = rsnewfeed(3) rsnewfeed.close If Not RSS_isPreview then Cache_Age = DateDiff("n", feed_date_cache, Now) If Cache_Age > RSS_CacheAge then Call Cache_Feed(ID) End If Else rsnewfeed.close Display_RSS = "Feed is not available." End If End Function '============================================================== ' RSS/RDF Syndicate Reader v0.95 ' http://www.kattanweb.com/webdev '-------------------------------------------------------------- ' Copyright(c) 2002, KattanWeb.com '============================================================== Const rssInit = 1 Const rssError = 2 Const rssBadRSS= 3 Const rssOK = 0 class kwRSS_reader Private Items() Private CurrentItem, TotalItems Public ChannelRSSURI, ChannelURL, ChannelTitle, ChannelDesc, ChannelLanguage, ChannelCategory Public ImageTitle, ImageLink, ImageURL Public TextInputURL, TextInputTitle, TextInputDesc, TextInputName Private Status '>>>>>>>> Setup Initialize event, called automtially when creating an instant of this class using ' Set rss = new kwRSS_reader Private Sub Class_Initialize CurrentItem = -1 TotalItems = -1 Redim Items(5, 500) '1st dimension = item's title/link/desc, 2nd dimension the item number Status = rssInit End Sub '>>>>>>>> Setup Terminate event, called automtially when killing an instant of this class using ' Set rss = nothing Private Sub Class_Terminate Erase Items End Sub '>>>>>>>> Load an RSS/RDF file and process it. Public Function ParseLocation(URL) ChannelRSSURI = URL set xmlObj = Server.CreateObject("Msxml2.DOMDocument.3.0") 'set xmlhttp= Server.CreateObject("Msxml2.XMLHTTP.3.0") set xmlhttp = Server.CreateObject("MSXML2.ServerXMLHTTP") xmlObj.validateOnParse = false xmlObj.async = false xmlObj.preserveWhiteSpace = false xmlhttp.open "GET", ChannelRSSURI, False xmlhttp.send rssXML_Data = xmlhttp.responseBody rssXML_Data = RSBinaryToString(rssXML_Data) ' --------- PHP-Nuke & PostNuke compatabilaty -------------------------------- rssXML_Data = replace(rssXML_Data, "", "rss-0.91.dtd""-->") ' ---------------------------------------------------------------------------- xmlObj.loadXML(rssXML_Data) If xmlObj.parseError.errorCode = 0 then ValidLocation = true else rssXML_Data = xmlhttp.responseXML.xml rssXML_Data = replace(rssXML_Data, "", "rss-0.91.dtd""-->") xmlObj.loadXML(rssXML_Data) If xmlObj.parseError.errorCode = 0 then ValidLocation = true Else ValidLocation = false End If end if set xmlhttp = nothing if not ValidLocation then Status = rssBadRSS Exit Function end if set rootNode = xmlObj.selectSingleNode("rdf:RDF") if rootNode is nothing then set rootNode = xmlObj.selectSingleNode("rss") if rootNode is nothing then Status = rssError else Reader rootNode, 0.91 end if else Reader rootNode, 1.0 end if set rootNode = nothing set xmlObj = nothing Status = rssOK End Function '>>>>>>>> Private sub to read the RSS/RDF according to its version Private Sub Reader(rootNode, ver) itemNum = -1 set SingleNode = rootNode.selectSingleNode("//channel/title") if Not SingleNode is nothing then ChannelTitle = SingleNode.text set SingleNode = rootNode.selectSingleNode("//channel/link") if Not SingleNode is nothing then ChannelURL = SingleNode.text set SingleNode = rootNode.selectSingleNode("//channel/description") if Not SingleNode is nothing then ChannelDesc = SingleNode.text set SingleNode = rootNode.selectSingleNode("//channel/language") if Not SingleNode is nothing then ChannelLanguage = SingleNode.text set SingleNode = rootNode.selectSingleNode("//channel/category") if Not SingleNode is nothing then ChannelCategory = SingleNode.text if ver = 1 then set child = rootNode.selectSingleNode("image") else set child = rootNode.selectSingleNode("//channel/image") end if if not child is nothing then set SingleNode = child.selectSingleNode("title") if Not SingleNode is nothing then ImageTitle = SingleNode.text set SingleNode = child.selectSingleNode("link") if Not SingleNode is nothing then ImageLink = SingleNode.text set SingleNode = child.selectSingleNode("url") if Not SingleNode is nothing then ImageURL = SingleNode.text end if set child = nothing if ver = 1 then set child = rootNode.selectSingleNode("textinput") else set child = rootNode.selectSingleNode("//channel/textinput") end if if not child is nothing then set SingleNode = child.selectSingleNode("title") if Not SingleNode is nothing then TextInputTitle = SingleNode.text set SingleNode = child.selectSingleNode("description") if Not SingleNode is nothing then TextInputDesc = SingleNode.text set SingleNode = child.selectSingleNode("name") if Not SingleNode is nothing then TextInputName = SingleNode.text set SingleNode = child.selectSingleNode("link") if Not SingleNode is nothing then TextInputURL = SingleNode.text end if set child = nothing set children = rootNode.selectNodes("//item") TotalItems = children.length for each child in children itemNum = itemNum + 1 if itemNum > ubound(Items, 2) then Redim Preserve Items(4, ubound(Items, 2) + 5) end if for each ItemChild in child.ChildNodes select case ItemChild.baseName case "title" Items(0, itemNum) = ItemChild.text case "link" Items(1, itemNum) = ItemChild.text case "description" Items(2, itemNum) = ItemChild.text case "pubDate" Items(3, itemNum) = ItemChild.text case "enclosure" encType = ItemChild.getAttribute("type") If Instr(1, encType, "image", 1) <> 0 then Items(4, itemNum) = ItemChild.getAttribute("url") End If case "category" Items(5, itemNum) = ItemChild.text end select next next if TotalItems > 0 then CurrentItem = 0 End Sub '>>>>>>>> Returns the title of the the current item Public Function GetTitle() GetTitle = Items(0, CurrentItem) End Function '>>>>>>>> Returns the url/link of the the current item Public Function GetLink() GetLink = Items(1, CurrentItem) End Function '>>>>>>>> Returns the description of the the current item Public Function GetDesc() GetDesc = Items(2, CurrentItem) End Function '>>>>>>>> Returns published date (Modified by GA Soft) Public Function GetDate() GetDate = Items(3, CurrentItem) End Function '>>>>>>>> Returns enclosure (Modified by GA Soft) Public Function GetEnclosure() GetEnclosure = Items(4, CurrentItem) End Function '>>>>>>>> Returns category (Modified by GA Soft) Public Function GetCategory() GetCategory = Items(5, CurrentItem) End Function '>>>>>>>> Goes to the next item Public Function MoveNext CurrentItem = CurrentItem + 1 End Function '>>>>>>>> Goes to the first item Public Function FirstItem if TotalItems > 0 then CurrentItem = 0 else CurrentItem = -1 end if End Function '>>>>>>>> Checks if the current location is a valid item or not Public Function ValidItem if CurrentItem > -1 and CurrentItem < TotalItems then ValidItem = true else ValidItem = false end if End Function '>>>>>>>> Checks if we are at EOF or not Public Function EOF if CurrentItem < TotalItems then EOF = false else EOF = true end if End Function '>>>>>>>> Returns status of the class Public Function GetStatus() GetStatus = Status end function '>>>>>>>> Returns Image provided in the RSS/RDF file as a linked image. Public Function GetImage() if ImageURL <> "" then if ImageLink <> "" then GetImage = "" GetImage = GetImage & "" if ImageLink <> "" then GetImage = GetImage & "" else GetImage = "" end if end function '>>>>>>>> Returns the code for the TextInput provided in the RSS/RDF file. Public Function GetTextInput() if TextInputURL <> "" then GetTextInput = "
" & vbCrLf & _ "" & vbCrLf & _ "" & vbCrLf & _ " " & vbCrLf & _ "" & vbCrLf & _ "" & vbCrLf & _ " " & vbCrLf & _ "" & vbCrLf & _ "" & vbCrLf & _ " " & vbCrLf & _ "" & vbCrLf & _ "
" & TextInputDesc & "
" & vbCrLf & _ "
" else GetTextInput = "" end if end function end class Function RSBinaryToString(xBinary) Dim Binary Set rssrs = Server.CreateObject("ADODB.Recordset") If vartype(xBinary)=8 Then Binary = MultiByteToBinary(xBinary) Else Binary = xBinary LBinary = LenB(Binary) If LBinary > 0 Then rssrs.Fields.Append "mBinary", 201, LBinary rssrs.Open rssrs.AddNew rssrs("mBinary").AppendChunk Binary rssrs.Update RSBinaryToString = rssrs("mBinary") rssrs.close Else RSBinaryToString = "" End If Set rssrs = Nothing End Function Function MultiByteToBinary(MultiByte) Dim LMultiByte, Binary Set rssrsm = Server.CreateObject("ADODB.Recordset") LMultiByte = LenB(MultiByte) If LMultiByte>0 Then rssrsm.Fields.Append "mBinary", 205, LMultiByte rssrsm.Open rssrsm.AddNew rssrsm("mBinary").AppendChunk MultiByte & ChrB(0) rssrsm.Update Binary = rssrsm("mBinary").GetChunk(LMultiByte) rssrsm.close End If Set rssrsm = Nothing MultiByteToBinary = Binary End Function %> <% Sub ExpireAds() setLocale server_locale On Error Resume Next Dim uNick, uEmail Select Case Application("Today_Expire_Flag" & strUnique) Case Empty Application("Today_Expire_Date" & strUnique) = Date Application("Today_Expire_Flag" & strUnique) = "1" ExpireAds Case "1" sdd = dd(objConn) If mysql then strSQL = "SELECT " & tablUPfx & "User.email," & tablPfx & "Ads.nick," & tablPfx & "Ads.catID," & tablPfx & "Ads.sCatID," & tablPfx & "Ads.adID," & tablPfx & "Ads.cat3rdID," & tablPfx & "Ads.subject FROM " & tablUPfx & "User," & tablPfx & "Ads WHERE " strSQL = strSQL & "(" & tablPfx & "Ads.userID = " & tablUPfx & "User.userID AND " & tablPfx & "Ads.status = 1 AND " & tablPfx & "Ads.edate <= CURDATE()) LIMIT 0,1;" Else strSQL = "SELECT TOP 1 " & tablUPfx & "User.email," & tablPfx & "Ads.nick," & tablPfx & "Ads.catID," & tablPfx & "Ads.sCatID," & tablPfx & "Ads.adID," & tablPfx & "Ads.cat3rdID," & tablPfx & "Ads.subject FROM " & tablUPfx & "User," & tablPfx & "Ads WHERE " strSQL = strSQL & "(" & tablPfx & "Ads.userID = " & tablUPfx & "User.userID AND " & tablPfx & "Ads.status = 1 AND " & tablPfx & "Ads.edate <= " & sdd & ConvDate(Date) & sdd & ");" End If set rsExp = objConn.Execute(strSQL) If rsExp.EOF then rsExp.close Set rsExp = Nothing If mysql then strSQL = "SELECT ID,userID,keyword,email,unick,alertlist FROM " & tablPfx & "Agent WHERE (alertlist <> '') LIMIT 0,1;" Else: strSQL = "SELECT TOP 1 ID,userID,keyword,email,unick,alertlist FROM " & tablPfx & "Agent WHERE (alertlist <> '');" End If set rsalert = objConn.Execute(strSQL) If Not rsalert.EOF then ID = CLng(rsalert(0)) userID = rsalert(1) alertKeys = rsalert(2) email = CryptText(rsalert(3), key, True) uNick = rsalert(4) alertlist = Trim(rsalert(5)) rsalert.close alertlistAllay = Split(alertlist) For each adID in alertlistAllay alertLinks = alertLinks & vbcrlf & web_site & "viewad.asp?id=" & CStr(adID) Next template = getTemplate("Alerts", Empty, Empty, uNick, Empty, Empty) uSubject = Split(template, s)(0) uBody = Split(template, s)(1) uBody = Replace(uBody, ":alertKeys:", alertKeys) uBody = Replace(uBody, ":alertLinks:", alertLinks) Call sendEmail(email, notify_email, uSubject, uBody) strSQL = "UPDATE " & tablPfx & "Agent SET alertlist = '' WHERE ID = " & ID & ";" objConn.Execute(strSQL) Else rsalert.close Set rsalert = Nothing tDate = ConvDate(Now) If mysql then strSQL = "SELECT ID,email,site FROM " & tablPfx & "Banner WHERE (((impr > 0 AND bview > impr) OR (edate < " & sdd & aDate & sdd & ")) AND status = 1) LIMIT 0,1;" Else: strSQL = "SELECT TOP 1 ID,email,site,bname FROM " & tablPfx & "Banner WHERE (((impr > 0 AND bview > impr) OR (edate < " & sdd & tDate & sdd & ")) AND status = 1);" End If Set rsRotExp = objConn.Execute(strSQL) If Not rsRotExp.EOF then ID = rsRotExp(0) uEmail = CryptText(rsRotExp(1), key, True) site = rsRotExp(2) rsRotExp.close objConn.Execute("UPDATE " & tablPfx & "Banner SET status = 0 WHERE ID = " & CLng(ID) & ";") template = getTemplate("Banner_Expire", Empty, Empty, Empty, Empty, Empty) uSubject = Split(template, s)(0) uBody = Split(template, s)(1) uBody = Replace(uBody, ":bsite:", site) Call sendEmail(uEmail, notify_email, uSubject, uBody) Application("cl_rotator" & strUnique) = Empty Application("isrotator" & strUnique) = Empty Else rsRotExp.close Application("Today_Expire_Date" & strUnique) = Date + 1 Application("Today_Expire_Flag" & strUnique) = "0" End If End If Else adID = rsExp(4) objConn.Execute("UPDATE " & tablPfx & "Ads SET status = 2 WHERE adID = '" & adID & "';") uEmail = CryptText(rsExp(0), key, True) uNick = rsExp(1) catID = rsExp(2) subcatID = rsExp(3) cat3rdID = rsExp(5) subject = rsExp(6) If isEvents then Call logEvent("Ad Expire", adID, subject, Empty, Empty, Empty) Call UpdateList(False, catID, subcatID, cat3rdID) template = getTemplate("Expired_Notification", Empty, Empty, uNick, Empty, adID) uSubject = Split(template, s)(0) uBody = Split(template, s)(1) Call sendEmail(uEmail, notify_email, uSubject, uBody) Application("cl_marquee" & strUnique) = Empty rsExp.close Set rsExp = Nothing End If Case "0" If Application("Today_Expire_Date" & strUnique) <= Date then Application("Today_Expire_Flag" & strUnique) = "1" ExpireAds End If End Select setLocale resetLocale On Error Goto 0 End Sub %> <% Function BuildContent(contentType, topDisplay, box, contentWidth) If not isNumeric(contentWidth) Then contentWidth = 200 tb_width = contentWidth - 14 contentType = CLng(contentType) topDisplay = CLng(topDisplay) msgNoAds = "
" & strText_NoAdshavebeenpostedyet & "
" & strText_Bethefirsttobelistedhere & "
" msgNoAccounts = "
" & strText_NoAccountshavebeencreatedyet & "
" & strText_Bethefirsttobelistedhere & "
" Select Case contentType '### TOP HOT ADS '---------------------------------------- Case 1 I = 1 If mysql then strSQL = "SELECT subject, adID FROM " & tablPfx & "Ads WHERE (hotlist = 1 AND status = 1) ORDER BY pdate DESC LIMIT 0," & topDisplay & ";" Else: strSQL = "SELECT TOP " & topDisplay & " subject, adID FROM " & tablPfx & "Ads WHERE (hotlist = 1 AND status = 1) ORDER BY pdate DESC;" End If set rs = objConn.Execute(strSQL) If not rs.EOF then strHot = "
" & vbcrlf Do While not rs.EOF If I > topDisplay then Exit Do title = rs(0) If Len(title) > 60 then title = Left(title, 60) & " ..." strHot = strHot & "" & vbcrlf strHot = strHot & "" & vbcrlf rs.MoveNext I = I + 1 Loop strHot = strHot & "
" & title & "

" & strText_AllHotAds & "

" End If If len(strHot) = 0 then strHot = msgNoAds rs.close BuildContent = strHot '### MOST VISITED ADS '------------------------------------------- Case 2 If mysql then strSQL = "SELECT subject, adID, adcounter FROM " & tablPfx & "Ads WHERE (status = 1) ORDER BY adcounter DESC LIMIT 0," & topDisplay & ";" Else: strSQL = "SELECT TOP " & topDisplay & " subject, adID, adcounter FROM " & tablPfx & "Ads WHERE (status = 1) ORDER BY adcounter DESC;" End If set rs = objConn.Execute(strSQL) If not rs.EOF then strPop = "
" & vbcrlf Do While not rs.EOF title = rs(0) If Len(title) > 30 then title = Left(title, 30) & " ..." strPop = strPop & "" & vbcrlf strPop = strPop & "" & vbcrlf rs.MoveNext Loop strPop = strPop & "
" & title & "
[" & rs(2) & "] " & strText_Hits & "
" End If If len(strPop) = 0 then strPop = msgNoAds rs.close BuildContent = strPop '### TOP POSTERS '------------------------------------------- Case 3 I = 1 If mysql then strSQL = "SELECT userID, nick, ads FROM " & tablUPfx & "User WHERE (status = 0) ORDER BY ads DESC LIMIT 0," & topDisplay & ";" Else: strSQL = "SELECT TOP " & topDisplay & " userID, nick, ads FROM " & tablUPfx & "User WHERE (status = 0) ORDER BY ads DESC;" End If set rs = objConn.Execute(strSQL) If not rs.EOF then strPoster = "
" & vbcrlf Do While not rs.EOF If I > topDisplay then Exit Do strPoster = strPoster & "" & vbcrlf strPoster = strPoster & "" & vbcrlf rs.MoveNext I = I + 1 Loop strPoster = strPoster & "
" & rs(1) & " [" & rs(2) & "] " & strText_Ads & "
" End If rs.close If Len(strPoster) = 0 then strPoster = msgNoAccounts BuildContent = strPoster '### TOP NEW ADS (Picked From "Content News" Template) '------------------------------------------- Case 4 I = 1 If mysql then strSQL = "SELECT subject, adID, adcounter FROM " & tablPfx & "Ads WHERE (status = 1) ORDER BY pdate DESC LIMIT 0," & topDisplay & ";" Else: strSQL = "SELECT TOP " & topDisplay & " subject, adID FROM " & tablPfx & "Ads WHERE (status = 1) ORDER BY pdate DESC;" End If set rs = objConn.Execute(strSQL) If not rs.EOF then strPop = "
" & vbcrlf Do While not rs.EOF If I > topDisplay then Exit Do title = rs(0) If Len(title) > 60 then title = Left(title, 60) & " ..." strPop = strPop & "" & vbcrlf strPop = strPop & "" & vbcrlf rs.MoveNext I = I + 1 Loop strPop = strPop & "
" & title & "
" End If If len(strPop) = 0 then strPop = msgNoAds rs.close BuildContent = strPop '### NEWS TEMPLATE '------------------------------------------- Case 5 templateName = "Content_News" set rs = objConn.Execute("SELECT " & tablPfx & "Template.body FROM " & tablPfx & "Template WHERE tname='" & templateName & "';") If not rs.EOF then BuildContent = Build_RSS(rs(0)) rs.close '### EDITORS PICK '------------------------------------------- Case 6 I = 1 strNoPick = "
" & strText_NoEdList & "
" strSQL = "SELECT subject, adID FROM " & tablPfx & "Ads WHERE (status = 1 AND epick = 1) ORDER BY pdate DESC;" set rs = objConn.Execute(strSQL) If Not rs.EOF then strPick = "
" & vbcrlf Do While not rs.EOF If I > topDisplay then Exit Do title = rs(0) If Len(title) > 60 then title = Left(title, 60) & " ..." strPick = strPick & "" & vbcrlf strPick = strPick & "" & vbcrlf rs.MoveNext I = I + 1 Loop strPick = strPick & "
" & title & "
" End If If len(strPick) = 0 then strPick = strNoPick rs.close BuildContent = strPick '### CUSTOM TEMPLATES '------------------------------------------- Case 11, 12, 13, 14, 15, 16 templID = contentType - 10 templateName = "Custom_" & templID set rs = objConn.Execute("SELECT " & tablPfx & "Template.body FROM " & tablPfx & "Template WHERE tname='" & templateName & "';") If not rs.EOF then BuildContent = Build_RSS(rs(0)) rs.close '### CATEGORIES TREE VIEW '------------------------------------------- Case 17 div_width = tb_width - 20 displCatAll = CStr(Request("id")) displCat = CStr(Request("cid")) displScat = CStr(Request("sid")) displ3rdCat = CStr(Request("3id")) If Len(displCat) = 0 And Len(displCatAll) = 0 then displCat = CStr(Request.Cookies("cat_me" & strSUnique)) If Len(displScat) = 0 And Len(displCatAll) = 0 then displScat = CStr(Request.Cookies("scat_me" & strSUnique)) If listalpha then If msaccess then tsorder = "ORDER BY lcase(tbCat.catName), lcase(tbscat.scatName), lcase(tb3ID.scatName);" Else: tsorder = "ORDER BY tbCat.catName, tbscat.scatName, tb3ID.scatName;" End If Else: tsorder = "ORDER BY tbCat.sortID, tbscat.sortID, tb3ID.sortID;" End If catNamet = "" scatNamet = "" If mysql then strsql = "SELECT tbCat.catID AS ID1st, tbCat.catName AS Name1st, tbCat.ads AS Ads1st, " strsql = strsql & "tbscat.sCatID AS ID2nd, tbscat.scatName AS Name2nd, tbscat.ads AS Ads2nd, " strsql = strsql & "tb3ID.sCatID AS ID3rd, tb3ID.scatName AS Name3rd, tb3ID.ads AS Ads3rd " strsql = strsql & "FROM " & tablPfx & "Cat AS tbCat " strsql = strsql & "LEFT JOIN " & tablPfx & "Scat AS tbscat ON tbscat.catID = tbCat.catID " strsql = strsql & "LEFT JOIN " & tablPfx & "Scat AS tb3ID ON tb3ID.catID = tbscat.scatID " strsql = strsql & tsorder Elseif mssql then strsql = "SELECT tbCat.catID AS ID1st, tbCat.catName AS Name1st, tbCat.ads AS Ads1st, " strsql = strsql & "tbscat.sCatID AS ID2nd, tbscat.scatName AS Name2nd, tbscat.ads AS Ads2nd, " strsql = strsql & "tb3ID.sCatID AS ID3rd, tb3ID.scatName AS Name3rd, tb3ID.ads AS Ads3rd " strsql = strsql & "FROM " & tablPfx & "Cat AS tbCat " strsql = strsql & "LEFT JOIN (" & tablPfx & "Scat AS tbscat LEFT JOIN " & tablPfx & "Scat AS tb3ID ON tb3ID.catID = tbscat.sCatID) " strsql = strsql & "ON tbscat.catID = tbCat.catID " strsql = strsql & tsorder Else strsql = "SELECT tbCat.catID AS ID1st, tbCat.catName AS Name1st, tbCat.ads AS Ads1st, " strsql = strsql & "tbscat.sCatID AS ID2nd, tbscat.scatName AS Name2nd, tbscat.ads AS Ads2nd, " strsql = strsql & "tb3ID.sCatID AS ID3rd, tb3ID.scatName AS Name3rd, tb3ID.ads AS Ads3rd " strsql = strsql & "FROM " & tablPfx & "Cat AS tbCat " strsql = strsql & "LEFT JOIN (" & tablPfx & "Scat AS tbscat LEFT JOIN " & tablPfx & "Scat AS tb3ID ON tb3ID.catID = tbscat.sCatID) " strsql = strsql & "ON tbscat.catID = tbCat.catID " strsql = strsql & tsorder End If Set rsTree = objConn.Execute(strsql) If not rsTree.EOF then rsdata = rsTree.getrows rsTree.close strTreeArray = "var treeArray = new Array(" allCatsCount = UBound(rsdata,2) strTree = "
" & vbcrlf strTree = strTree & "" For C = 0 to allCatsCount currcatName = rsdata(1,C) currscatName = rsdata(4,C) currcat3rdName = rsdata(7,C) If currcatName <> catNamet then If Len(CStr(cat3rdIDt)) > 0 then strTree = strTree & "" If Len(CStr(sCatIDt)) > 0 then strTree = strTree & "" sCatIDt = Empty cat3rdIDt = Empty catNamet = currcatName catIDt = rsdata(0,C) adst = rsdata(2,C) strTreeArray = strTreeArray & catIDt & "," If (Len(displCatAll) > 0 And displCatAll = CStr(catIDt)) Or (Len(displCat) > 0 And displCat = CStr(catIDt)) then catStyle = "style='font-weight: bold' " Else: catStyle = Empty End If If Len(displCat) > 0 And displCat = CStr(catIDt) then strDisplay = "" catClass = "a1" Else strDisplay = "display:none;" catClass = "a" End If strTree = strTree & "
" & strText_ExpandAll & " | " & strText_CollapseAll & "
" strTree = strTree & "
" strTree = strTree & " " & catNamet & "" strTree = strTree & " .................................................................................
" strTree = strTree & "
[" & adst & "]
" strTree = strTree & "

" firstCatFound = True End If If currscatName <> scatNamet then If Len(CStr(cat3rdIDt)) > 0 then strTree = strTree & "
" cat3rdIDt = Empty newSubcat = True scatNamet = currscatName sCatIDt = rsdata(3,C) If Len(displsCat) > 0 And displsCat = CStr(sCatIDt) then scatStyle = "style='font-weight: bold;' " Else: scatStyle = Empty End If sadst = rsdata(5,C) strTree = strTree & "
" strTree = strTree & " " & scatNamet & " [" & sadst & "]
" End If If Len(currcat3rdName) > 0 then cat3rdIDt = rsdata(6,C) c3adst = rsdata(8,C) If Len(displ3rdCat) > 0 And displ3rdCat = CStr(cat3rdIDt) then cat3Style = "style='font-weight: bold;' " Else: cat3Style = Empty End If If newSubcat then strTreeArray = strTreeArray & sCatIDt & "," If Len(displsCat) > 0 And displsCat = CStr(sCatIDt) then str3Display = "" cat3Class = "s0" Else str3Display = "display:none;" cat3Class = "s1" End If strTree = strTree & "
" strTree = strTree & "" End If newSubcat = False strTree = strTree & "
" strTree = strTree & " " & currcat3rdName & " [" & c3adst & "]
" End If Next strTree = strTree & "

" Erase rsdata Set rsdata = Nothing strTreeArray = Left(strTreeArray, Len(strTreeArray) - 1) & ");" End If strTree = strTree & "" BuildContent = strTree '### FIRST LEVEL CATEGORIES '------------------------------------------- Case 18 div_width = tb_width - 50 catNamet = "" If listalpha then sortorder = "catName": else sortorder = "sortID" strsql = "SELECT catID,catName,ads FROM " & tablPfx & "Cat ORDER BY " & sortorder & ";" Set rsCatList = objConn.Execute(strsql) If not rsCatList.EOF then rsdata = rsCatList.getrows rsCatList.close allCatsCount = UBound(rsdata,2) strCatList = "
" & vbcrlf For C = 0 to allCatsCount currcatID = rsdata(0,C) currcatName = rsdata(1,C) currcatAds = rsdata(2,C) If Request("id") = CStr(currcatID) Or Request("cid") = CStr(currcatID) then catStyle = "style='font-weight: bold;' " Else: catStyle = Empty End If strCatList = strCatList & "" & vbcrlf strCatList = strCatList & "" & vbcrlf Next strCatList = strCatList & "
" strCatList = strCatList & "" & currcatName & "" strCatList = strCatList & "  ........................................................
" strCatList = strCatList & "
[" & currcatAds & "]
" Erase rsdata Set rsdata = Nothing BuildContent = strCatList Else: rsCatList.close End If End Select End Function %> <% Function ConvDate(passDate) passDate = DateAdd("h", timeOffset, CDate(passDate)) '### Database Date Format yyyy-mm-dd ************************* date_part = DatePart("yyyy", passDate) & "-" & Right(DatePart("m", passDate) + 100, 2) & "-" & Right(DatePart("d", passDate) + 100, 2) '### Database Date Format dd/mm/yyyy ************************* 'date_part = Right(DatePart("d", passDate) + 100, 2) & "/" & Right(DatePart("m", passDate) + 100, 2) & "/" & DatePart("yyyy", passDate) '### Database Date Format mm/dd/yyyy ************************* 'date_part = Right(DatePart("m", passDate) + 100, 2) & "/" & Right(DatePart("d", passDate) + 100, 2) & "/" & DatePart("yyyy", passDate) time_part = " " & Right(DatePart("h", passDate) + 100, 2) & ":" & Right(DatePart("n", passDate) + 100, 2) & ":" & Right(DatePart("s", passDate) + 100, 2) ConvDate = date_part & time_part End Function Function ConvDateShort(passDate) ConvDateShort = ConvDate(passDate) End Function Function readFile(rFile, iArray) Set riFile = objFile.GetFile(rFile) Set recordGet=objFile.OpenTextFile(riFile, 1, False) On Error Resume Next rec = recordGet.Read(riFile.Size) On Error GoTo 0 recordGet.Close rec = ClearCarriageReturn(rec) Select Case iArray Case True: readFile = Split(rec, vbCrLf) Case False: readFile = rec Case "decode" recArray = Split(rec, vbCrLf) For each recItem in recArray recItem = CryptText(recItem, key, True) decodeRec = decodeRec & vbCrLf & recItem Next decodeRec = ClearCarriageReturn(decodeRec) readFile = decodeRec End Select End Function Sub writeFile(iFile, iData) iData = ClearCarriageReturn(iData) Set recordSet = objFile.OpenTextFile(iFile, 2, True) recordSet.WriteLine iData recordSet.Close Set iData = Nothing End Sub Sub appendFile(iFile, iData) Set recordSet = objFile.OpenTextFile(iFile, 8, False) recordSet.WriteLine iData recordSet.Close End Sub Function RandomNumber() Randomize RandomNumber = Int((899999 * Rnd) + 100000) End Function Function ClearCarriageReturn(recClearRet) Do Until Not Right(recClearRet, 2) = vbCrLf And Not Left(recClearRet, 2) = vbCrLf If Right(recClearRet, 2) = vbCrLf Then recClearRet = Left(recClearRet, Len(recClearRet) - 2) If Left(recClearRet, 2) = vbCrLf Then recClearRet = Right(recClearRet, Len(recClearRet) - 2) Loop ClearCarriageReturn = recClearRet End Function '*** This function enables posting http links within comment area if HTML is disabled. Function encodeURL(text) set re = new RegExp re.global=true re.ignoreCase=true re.Pattern = "(((http)|(ftp)|(https))(://)(\w|-)+(\.)(\w|-|\.|/|\?|&|=|/|:|;|#|%|\+)+)" temp = re.replace(text, "") re.Pattern = "([A-Za-z0-9_\-\.]+@(\w+|\w+-\w+)\.[A-Za-z0-9_\.]+)" encodeURL = re.replace(temp, " ($1)") End Function Function UpdateList(action, catID, scatID, cat3rdID) Select Case action Case True: strOperator = "+ 1" Case False: strOperator = "- 1" End Select catID = CLng(catID) scatID = CLng(scatID) cat3rdID = CLng(cat3rdID) objConn.Execute("UPDATE " & tablPfx & "Cat SET ads = ads " & strOperator & " WHERE catID = " & catID & ";") objConn.Execute("UPDATE " & tablPfx & "Scat SET ads = ads " & strOperator & " WHERE sCatID = " & scatID & ";") If cat3rdID > 0 then objConn.Execute("UPDATE " & tablPfx & "Scat SET ads = ads " & strOperator & " WHERE catID = " & scatID & " AND sCatID = " & cat3rdID & ";") End Function Function RotateBanner(zone) If Application("isrotator" & strUnique) = "0" then Exit Function If Not isArray(Application("cl_rotator" & strUnique)) then loadRotator RotateBanner = rotate(zone) End Function Sub loadRotator() Dim tempRotator(10), tempRotatorWeight(10), tempRelWeight(10) Application("cl_rotator" & strUnique) = Empty Application("cl_weight" & strUnique) = Empty Application("isrotator" & strUnique) = Empty strSQL = "SELECT " & tablPfx & "Banner.ID,bname,altText,bannercode,weight,iscode,site," & tablPfx & "Zone.zid FROM " strSQL = strSQL & tablPfx & "Zone LEFT JOIN " & tablPfx & "Banner ON (" strSQL = strSQL & tablPfx & "Banner.izone = " & tablPfx & "Zone.zid) WHERE (isactive = 1 AND status = 1);" set rsRot = objConn.Execute(strSQL) If not rsRot.EOF then ztable = rsRot.getrows: Else: Dim ztable(7,0) rsRot.close For I = 1 to 10 strRotator = Empty strWeight = Empty strRelWight = 0 For m = 0 to UBound(ztable,2) If Clng(ztable(7, m)) = I Then strRotator = strRotator & ss & ztable(0, m) & s & ztable(1, m) & s & ztable(2, m) & s & ztable(3, m) & s & ztable(5, m) & s & ztable(6, m) nextW = ztable(4, m) strWeight = strWeight & " " & CStr(nextW) strRelWight = strRelWight + CLng(nextW) foundBanner = True End If Next If strRelWight > 0 then strWeight = setPriority(strWeight, strRelWight) strRotator = Replace(strRotator, ss, "", 1,1,1) tempRotator(I) = strRotator tempRotatorWeight(I) = strWeight tempRelWeight(I) = strRelWight Next Application("cl_relWeight" & strUnique) = tempRelWeight Application("cl_rotator" & strUnique) = tempRotator Application("cl_weight" & strUnique) = tempRotatorWeight If Not foundBanner then Application("isrotator" & strUnique) = "0" Erase tempRelWeight: Erase tempRotator: Erase tempRotatorWeight End Sub Function setPriority(priority, prsum) priority = Trim(priority) priorityArray = Split(priority, " ") For I = 0 To Ubound(priorityArray) NextPriority = priorityArray(I) bweight = ((NextPriority * 1000) \ prsum) + bweight If I = Ubound(priorityArray) Then bweight = 1000 setPriority = setPriority & "," & bweight Next setPriority = Replace(setPriority, ",", "", 1, 1, 1) End Function Function rotate(zone) On Error resume Next Dim strWeight, J, arrayWeight, RandomBanner, randomIndex Dim rotateString, bannerArray, rotateArray, rotateCode If Len(Application("cl_rotator" & strUnique)(zone)) > 10 then setLocale server_locale Randomize RandomBanner = Int((1000 * Rnd) + 1) strWeight = Application("cl_weight" & strUnique)(zone) arrayWeight = Split(strWeight, ",") For J = 0 to Ubound(arrayWeight) If RandomBanner <= CLng(arrayWeight(J)) then randomIndex = J: Exit For Next Erase arrayWeight bannerArray = Split(Application("cl_rotator" & strUnique)(zone), ss) rotateString = bannerArray(randomIndex) Erase bannerArray rotateArray = Split(rotateString, s) Select Case rotateArray(4) Case "1" banner = rotateArray(1) rotateCode = rotateArray(3) outID = CLng(rotateArray(0)) Case "0" banner = rotateArray(1) outID = CLng(rotateArray(0)) altText = rotateArray(2) rotateCode = ""
				rotateCode = rotateCode & altText & "" End Select sdd = dd(objConn) aDate = ConvDate(Date) objConn.Execute("UPDATE " & tablPfx & "Banner SET bview=bview+1 WHERE ID =" & outID & ";") Set ret = objConn.Execute("UPDATE " & tablPfx & "Bannerstat SET display=display+1 WHERE (bname='" & banner & "' AND adate= " & sdd & aDate & sdd & ");", numrow, adExecuteNoRecords) If numrow = 0 then objConn.Execute("INSERT INTO " & tablPfx & "Bannerstat(bname,adate,display,click) VALUES('" & sqbl(banner) & "'," & sdd & aDate & sdd & ",1,0);") End If rotate = rotateCode setLocale resetLocale End If On Error goto 0 End Function Function sq(inputstr) inputstr = Replace(inputstr,"\'", "'") sq = Replace(inputstr, "'", "''") End Function Function sqbl(inputstr) sqbl = Replace(inputstr, "'", "") End Function Function dd(ByRef conObj) strDateDelimiter = "'" If msaccess Then strDateDelimiter = "#" dd = strDateDelimiter End Function Function buildPages(nPage, URLlink, pageType) rs.PageSize = pp rs.CacheSize = pp If Len(nPage) = 0 Then rs.AbsolutePage = 1 Else If isNumeric(nPage) And Not nPage = 0 then If CLng(nPage) <= rs.PageCount Then rs.AbsolutePage = nPage Else: rs.AbsolutePage = 1 End If Else: rs.AbsolutePage = 1 End If End If currentPage = rs.AbsolutePage totalPage = rs.PageCount totalRecords = rs.RecordCount displayRecords = pp remRecords = totalRecords Mod pp If totalRecords < pp then displayRecords = totalRecords If currentPage = totalPage And Not remRecords = 0 then displayRecords = remRecords limitPage = 10 remain = currentPage Mod limitPage range = currentPage \ limitPage If remain <> 0 Then range = range + 1 lastpage = limitPage * range firstpage = lastpage - limitPage + 1 If lastpage > totalPage then lastpage = totalPage nextRange = lastpage + 1 prevRange = firstpage - 1 If prevRange = 0 Then prevLink = "" & strText_Previous & " 10 " & strText_Pages & "" Else prevLink = "" & strText_Previous & " 10 " & strText_Pages & "" End If If nextRange > totalPage Then nextLink = "" & strText_Next & " 10 " & strText_Pages & "" Else nextLink = "" & strText_Next & " 10 " & strText_Pages & "" End If firstPageLink = "" & strText_FirstPage & "" lastPageLink = "" & strText_LastPage & "" For n = firstpage to lastpage If n = currentPage then links = links & " (" & n & ") " Else links = links & " [" & n & "] " End If Next paging = "
" & strText_Pages & ": " & links paging = paging & "
" & firstPageLink & " | " & prevLink & " | " & nextLink & " | " & lastPageLink & "
" buildPages = paging End Function Function strMarquee() If Len(Application("cl_marquee" & strUnique)) = 0 then topMarquee = 5 If mysql then strSQL = "SELECT adID,subject FROM " & tablPfx & "Ads WHERE status = 1 ORDER BY pdate DESC LIMIT 0," & topMarquee & ";" Else: strSQL = "SELECT TOP " & topMarquee & " adID,subject FROM " & tablPfx & "Ads WHERE status = 1 ORDER BY pdate DESC;" End If set rsm = objConn.Execute(strSQL) If not rsm.EOF then Do While not rsm.EOF strTemp = strTemp & "" & Replace(rsm(1), chr(34), "") & "<\/a><\/span>" strRemote = strRemote & "" & Replace(rsm(1), chr(34), "") & "<\/span><\/a>""+br+""" rsm.MoveNext Loop strMarquee = strTemp Application("cl_marquee" & strUnique) = strTemp Else strMarquee = strText_NoSubmissions Application("cl_marquee" & strUnique) = strMarquee End If If Len(strRemote) > 0 Then strRemoteTicker = "" writeFile Server.MapPath(upload) & "\feed.js", strRemoteTicker End If Else: strMarquee = Application("cl_marquee" & strUnique) End If End Function Function HTMLEncode(text) newtext = Replace(text, "<", "") newtext = Replace(text, ">", "") HTMLEncode = newtext End Function Function matchAlerts(adID, catID, scatID, cat3rdID, subject, body) On Error Resume Next catID = CLng(catID) scatID = CLng(scatID) If IsNumeric(cat3rdID) AND Len(CStr(cat3rdID)) > 1 then cat3rdID = CLng(cat3rdID): Else: cat3rdID = 0 strSQL = "SELECT " & tablPfx & "Agent.* FROM " & tablPfx & "Agent WHERE " strSQL = strSQL & "(catID = " & catID & " AND scatID = " & scatID & " AND cat3rdID = " & cat3rdID & ")" strSQL = strSQL & " OR (catID = " & catID & " AND scatID = " & 0 & ")" strSQL = strSQL & " OR (catID = " & catID & " AND scatID = " & 0 & ")" strSQL = strSQL & " OR (catID = " & 0 & " AND scatID = " & 0 & ");" set rsa = objConn.Execute(strSQL) If not rsa.EOF then Do While Not rsa.EOF ID = CLng(rsa(0)) stype = CLng(rsa(3)) keywords = rsa(2) Select Case stype Case 1 matchFound = False keyArray = Split(keywords) For each ikey in keyArray If instr(1, subject, ikey, 1) <> 0 Or instr(1, body, ikey, 1) <> 0 Then matchFound = True: Exit For Next Case 2 matchFound = True keyArray = Split(keywords) For each ikey in keyArray If instr(1, subject, ikey, 1) = 0 AND instr(1, body, ikey, 1) = 0 Then matchFound = False: Exit For Next Case 3 matchFound = False If instr(1, subject, keywords, 1) <> 0 Or instr(1, body, keywords, 1) <> 0 Then matchFound = True End Select If matchFound Then If not rsa(12) = Empty then straddAlert = "alertlist = alertlist + ' " & adID & "'" Else: straddAlert = " alertlist = ' " & adID & "'" If mysql then straddAlert = "alertlist = CONCAT(alertlist, ' " & adID & "')" objConn.Execute("UPDATE " & tablPfx & "Agent SET " & straddAlert & " WHERE ID = " & ID & ";") End If rsa.MoveNext Loop End If rsa.close On Error Goto 0 End Function Sub checkIP(uIP) If Len(uIP) > 5 then If Not detectMultipleIP then Exit Sub set rsIP = objConn.Execute("SELECT userID,nick,email FROM " & tablUPfx & "User WHERE IP='" & uIP & "';") If not rsIP.EOF then rsdata = rsIP.getrows rsIP.close numrows = UBound(rsdata,2) + 1 If numrows > 1 then For m = 0 to UBound(rsdata,2) strBodyx = strBodyx & vbcrlf & "User ID: " & rsdata(0, m) & ", User Nick: " & rsdata(1, m) & ", User Email: " & CryptText(rsdata(2, m), key, True) Next On Error Resume Next Set DNSLook = Server.CreateObject("AspDNS.Lookup") dnsHost = DNSLook.ReverseDNSLookup(uIP) On Error Goto 0 strBodyx = "Multiple accounts has possibly been created:" & vbcrlf & vbcrlf & strBodyx & vbcrlf & vbcrlf strBodyx = strBodyx & "User Logged from: " & uIP & " to all of the above accounts." If Len(dnsHost) > 0 then strBodyx = strBodyx & vbcrlf & "Host Name: " & dnsHost strSubject = web_name & " - multiple account detected." Call sendEmail(admin_email, admin_email, strSubject, strBodyx) End If Else: rsIP.close End If End If End Sub Sub build_Meta() static_ads_keywords = "buy, sell" On Error Resume Next scr_Path = Request.ServerVariables("SCRIPT_NAME") scr_Path_Array = Split(scr_Path, "/") scr_Name = Lcase(scr_Path_Array(Ubound(scr_Path_Array))) Select Case scr_Name Case "viewscat.asp" If IsNumeric(Request("id")) then mcatID = Request("id") set rscat = objConn.Execute("SELECT catFullDescr,catMetaDescr,catMetaKey,catTitle FROM " & tablPfx & "Cat WHERE catID = " & CLng(mcatID) & ";") If not rscat.EOF then full_description = rscat(0) result_meta_description = rscat(1) result_meta_keywords = rscat(2) result_web_name = rscat(3) End If rscat.close End If Case "viewlist.asp" on error goto 0 If IsNumeric(Request("cid")) and IsNumeric(Request("sid")) then mscatID = Request("sid") mcatID = Request("cid") strSQL = "SELECT " & tablPfx & "Cat.catFullDescr," & tablPfx & "Cat.catMetaDescr," & tablPfx & "Cat.catMetaKey," & tablPfx & "Cat.catTitle," strSQL = strSQL & tablPfx & "Scat.scatFullDescr," & tablPfx & "Scat.scatMetaDescr," & tablPfx & "Scat.scatMetaKey," & tablPfx & "Scat.scatTitle, " strSQL = strSQL & tablPfx & "Scat.scatName," & tablPfx & "Cat.catName " strSQL = strSQL & "FROM " & tablPfx & "Cat, " & tablPfx & "Scat WHERE " & tablPfx & "Cat.catID = " & CLng(mcatID) & " AND " & tablPfx & "Scat.sCatID = " & CLng(mscatID) & ";" set rscat = objConn.Execute(strSQL) If not rscat.EOF then full_description = rscat(4) result_meta_description = rscat(5) result_meta_keywords = rscat(6) result_web_name = rscat(7) catName = rscat(9) subCatName = rscat(8) If ((IsNull(result_web_name) OR Len(result_web_name) = 0) And default_to_cat) or Request("sa") = 1 then full_description = rscat(0) result_meta_description = rscat(1) result_meta_keywords = rscat(2) result_web_name = rscat(3) End If End If rscat.close End If Case "viewsublist.asp" If IsNumeric(Request("cid")) and IsNumeric(Request("sid")) and IsNumeric(Request("3id")) then mscat3rdID = Request("3id") mcatID = Request("cid") mscatID = Request("sid") strSQL = "SELECT scatFullDescr,scatMetaDescr,scatMetaKey,scatTitle,scatName FROM " & tablPfx & "Scat WHERE catID = " & CLng(mscatID) & " AND sCatID = " & CLng(mscat3rdID) & ";" set rscat = objConn.Execute(strSQL) If not rscat.EOF then full_description = rscat(0) result_meta_description = rscat(1) result_meta_keywords = rscat(2) result_web_name = rscat(3) cat3rdName = rscat(4) If (IsNull(result_web_name) OR Len(result_web_name) = 0) And default_to_cat then strSQL = "SELECT " & tablPfx & "Cat.catFullDescr," & tablPfx & "Cat.catMetaDescr," & tablPfx & "Cat.catMetaKey," & tablPfx & "Cat.catTitle," strSQL = strSQL & tablPfx & "Scat.scatFullDescr," & tablPfx & "Scat.scatMetaDescr," & tablPfx & "Scat.scatMetaKey," & tablPfx & "Scat.scatTitle " strSQL = strSQL & "FROM " & tablPfx & "Cat, " & tablPfx & "Scat WHERE " & tablPfx & "Cat.catID = " & CLng(mcatID) & " AND " & tablPfx & "Scat.sCatID = " & CLng(mscatID) & ";" set rscat = objConn.Execute(strSQL) If not rscat.EOF then full_description = rscat(4) result_meta_description = rscat(5) result_meta_keywords = rscat(6) result_web_name = rscat(7) If (IsNull(result_web_name) OR Len(result_web_name) = 0) And default_to_cat then full_description = rscat(0) result_meta_description = rscat(1) result_meta_keywords = rscat(2) result_web_name = rscat(3) End If End If End If End If rscat.close End If Case "viewad.asp", "view_print.asp" If IsNumeric(Request("id")) then madID = Request("id") strSQL = "SELECT subject,uopt8 FROM " & tablPfx & "Ads WHERE adID = '" & madID & "';" set rsad = objConn.Execute(strSQL) If not rsad.EOF then msubject = rsad(0) adStyle = rsad(1) msubject = replace(msubject, ".", "") msubject = replace(msubject, ",", "") msubject = replace(msubject, "?", "") msubject = replace(msubject, "!", "") msubject = replace(msubject, ":", "") result_web_name = msubject result_meta_description = msubject subject_array = Split(msubject) For Each metakey in subject_array If Len(metakey) > 2 then loose_key = loose_key & ", " & metakey Next mscatID = Left(madID, 5) strSQL = "SELECT " & tablPfx & "Cat.catName, " & tablPfx & "Scat.scatName FROM " strSQL = strSQL & tablPfx & "Cat, " & tablPfx & "Scat WHERE " & tablPfx & "Cat.catID = " & tablPfx & "Scat.catID AND " & tablPfx & "Scat.sCatID = " & CLng(mscatID) & ";" set rsadc = objConn.Execute(strSQL) If not rsadc.EOF then mcatName = rsadc(0) mscatName = rsadc(1) End If rsadc.close If len(mcatName) > 0 then result_web_name = result_web_name & " - " & mcatName & " : " & mscatName result_meta_keywords = static_ads_keywords & ", " & msubject & loose_key If Len(adStyle) > 0 and uOpt(7) = "1" then dstyle = adStyle End If rsad.close End If Case "adpreview.asp" adPreviewStyle = Request.Form("uO7") If Len(adPreviewStyle) > 0 then dstyle = adPreviewStyle End Select If Len(result_web_name) = 0 or IsNull(result_web_name) then result_web_name = web_name If IsNull(result_meta_description) OR Len(result_meta_description) = 0 then result_meta_description = meta_description If IsNull(result_meta_keywords) OR Len(result_meta_keywords) = 0 then result_meta_keywords = meta_keywords On Error goto 0 End Sub Sub cacheAds(adID) On Error Resume Next Server.ScriptTimeout = 10000 Set xml = Server.CreateObject("MSXML2.ServerXMLHTTP") xml.Open "GET", Application("Classify_Main_Config" & strUnique)(1) & "view_print.asp?id=" & adID, False xml.send cache_content = xml.responseBody Set xml = Nothing cache_content = Trim(cache_content) cache_content = Unicode(cache_content) If Len(cache_content) > 2000 then writeFile server.mappath(ad_cache) & "\" & adID & ".htm", cache_content On Error Goto 0 End Sub Function Unicode(b) t = String(LenB(b), " ") t = "" For i = 1 To LenB(b) t = t & Chr(AscB(MidB(b, i, 1))) Next Unicode = t End Function Function isCompatible() On Error Resume Next user_browser = CStr(uagent) Set re = New RegExp re.Global = True re.IgnoreCase = True re.pattern = "(Safari)" If re.test(user_browser) Then isCompatible = False Exit Function End If re.pattern = "(MSIE )(\d\.\d*)" If re.test(user_browser) Then Set matches = re.execute(user_browser) For each match in matches bver = match.SubMatches(1) Next setLocale server_locale If Len(CStr(bver)) > 0 And isNumeric(bver) then If bver >= 5.5 then isCompatible = True End If End If setLocale resetLocale Exit Function End If isCompatible = True End Function Sub logEvent(event_type, eopt0, eopt1, eopt2, eopt3, eopt4) ldate = ConvDate(Now) sdd = dd(objConn) If Len(Sess_Array(48)) > 0 then isAdmin ="Yes": Else: isAdmin = "=" If Sess_Array(29) > 0 then userID_Log = Sess_Array(29) nick_Log = sq(Sess_Array(51)) isUser = "" & nick_Log & "" Else: isUser = "=" End If Select Case event_type Case "New Ad" eID = 1 eicon = "enewad.gif" ldescr = "New Ad Posted: " & eopt1 & "" If eventsArray(1) then isLogEvent = True Case "Update Ad" eID = 2 eicon = "emodad.gif" ldescr = "Ad Modified: " & eopt1 & "" & eopt2 If eventsArray(2) then isLogEvent = True Case "Ad Expire" eID = 3 eicon = "eexpad.gif" ldescr = "Ad Expired: " & eopt1 & "" If eventsArray(3) then isLogEvent = True Case "Ad Deleted" eID = 4 eicon = "edelad.gif" ldescr = "Ad Deleted. Ad ID: " & eopt0 & eopt1 If eventsArray(4) then isLogEvent = True Case "New Account" eID = 5 eicon = "enewuser.gif" ldescr = "New Account Created. User: " & eopt1 & "" & eopt2 If eventsArray(5) then isLogEvent = True Case "Account Updated" eID = 6 eicon = "emoduser.gif" ldescr = "Account Modified. User: " & eopt1 & "" & eopt2 If eventsArray(6) then isLogEvent = True Case "Account Activated" eID = 7 eicon = "eactuser.gif" ldescr = "Account Activated. User: " & eopt1 & "" & eopt2 If eventsArray(7) then isLogEvent = True Case "Account Suspended" eID = 8 eicon = "esususer.gif" ldescr = "Account Suspended. User: " & eopt1 & "" If eventsArray(8) then isLogEvent = True Case "Account Deleted" eID = 9 eicon = "edeluser.gif" ldescr = "Account(s) Deleted. " & eopt0 If eventsArray(9) then isLogEvent = True Case "Contact" eID = 10 eicon = "eadmcont.gif" ldescr = "Admin Contacted by: " & eopt1 & " Message: " & eopt2 & eopt3 If eventsArray(10) then isLogEvent = True Case "Contact Friend" eID = 11 eicon = "efrdcont.gif" ldescr = "Friend Contacted. From: " & eopt0 & " To: " & eopt2 & " Message: " & eopt3 ldescr = ldescr & "
Ad referred" If eventsArray(11) then isLogEvent = True Case "User Logon" eID = 12 eicon = "eloguser.gif" ldescr = "User Successfully Logged on " & eopt0 If eventsArray(12) then isLogEvent = True Case "User Logon Denied" eID = 13 eicon = "edenuser.gif" ldescr = "User Access Denied: " & eopt0 & eopt1 If eventsArray(13) then isLogEvent = True Case "Admin Logon" eID = 14 eicon = "elogadmin.gif" ldescr = "Admin Successfully Logged on" If eventsArray(14) then isLogEvent = True Case "Admin Logon Denied" eID = 15 eicon = "edenadmin.gif" ldescr = "Access to Admin page Denied!" If eventsArray(15) then isLogEvent = True Case "Custom1" eID = 16 eicon = "ecustom1.gif" ldescr = eopt0 If eventsArray(16) then isLogEvent = True Case "Custom2" eID = 17 eicon = "ecustom2.gif" ldescr = eopt0 If eventsArray(17) then isLogEvent = True Case "Custom3" eID = 18 eicon = "ecustom3.gif" ldescr = eopt0 If eventsArray(18) then isLogEvent = True Case "Custom4" eID = 19 eicon = "ecustom4.gif" ldescr = eopt0 If eventsArray(19) then isLogEvent = True Case "Custom5" eID = 20 eicon = "ecustom5.gif" ldescr = eopt0 If eventsArray(20) then isLogEvent = True Case else eID = 0 eicon = "ecustom1.gif" ldescr = "Unknown event" isLogEvent = True End Select If isLogEvent then strSQL = "INSERT INTO " & tablPfx & "Events(ldefine,eID,ldate,ltype,IP,ldescr,luser,ladmin) VALUES('" & event_type & "'," & eID & "," & sdd & ldate & sdd strSQL = strSQL & ",'" & eicon & "','" & IP & "','" & sq(ldescr) & "','" & isUser & "','" & isAdmin & "');" objConn.Execute(strSQL) End If End Sub Function checkDefault(typeVal) If IsNull(typeVal) then checkDefault = True ElseIf Trim(typeVal) = Empty Or Trim(lcase(typeVal)) = "default" then checkDefault = True Else: checkDefault = False End If End Function Sub loadScheme(cid,sid,c3id,isLimitOnly) If c3id = 0 then strSQL = "SELECT ftype FROM " & tablPfx & "Scat WHERE sCatID=" & sid & ";" Else: strSQL = "SELECT ftype FROM " & tablPfx & "Scat WHERE sCatID=" & c3id & ";" End If ftype = objConn.Execute(strSQL)(0) If checkDefault(ftype) then ftype = "default" Set rsls = objConn.Execute("SELECT * FROM " & tablPfx & "Fees WHERE ftype = '" & ftype & "';") If not rsls.EOF then Select Case isnotfree Case True For I = 0 to 11 ppArray(I) = rsls("pa" & I+1) Next ppArray(15) = rsls("pa16") For I = 25 to 29 ppArray(I) = rsls("pa" & I+1) Next Case False ppArray(25) = rsls("pa26") ppArray(26) = rsls("pa27") ppArray(27) = rsls("pa28") ppArray(28) = rsls("pa29") ppArray(29) = rsls("pa30") End Select End If rsls.close End Sub Sub UpdateSessions(isSessUpdate) On Error Resume Next If Not isSEngine AND isSessUpdate Then For scount = 0 to 100 Sess_Data_Back = Sess_Data_Back & Sess_Array(scount) & ss Next sdd = dd(objConn) objConn.Execute("UPDATE " & tablUPfx & "Sess SET sess_date = " & sdd & ConvDate(Now) & sdd & " , sess_data = '" & sq(Sess_Data_Back) & "' WHERE (sess_ID = '" & Request.Cookies("sess_ID" & strSUnique) & "' AND sess_IP = '" & IPR & "');") End If objConn.close Set rs = Nothing Set objConn = Nothing Set objFile = Nothing Erase Sess_Array Erase advArray Erase ppArray Erase uOpt Erase uOptD Erase uOptType Erase uOptSearch Erase eventsArray End Sub Function gettf(tf) gettf = Replace(tf, ".", "_tb.") End Function Function parseScategoryIcon(strKey) parseScategoryIcon = strKey If IsNull(strKey) Or Len(strKey) = 0 Then parseScategoryIcon = "folders.gif" End Function Function buildOptionList() set rscat = objConn.Execute("SELECT " & tablPfx & "Cat.catName, " & tablPfx & "Cat.catID FROM " & tablPfx & "Cat ORDER BY " & cat_sortorder & ";") optCatList = "" If not rscat.EOF then Do While Not rscat.EOF catName = rscat(0) catID = rscat(1) If CStr(sTarget) = CStr(catID) then build = true optCatList = optCatList & "" Else: optCatList = optCatList & "" End If rscat.MoveNext Loop End If If not build then Application("Cat_List" & strUnique) = optCatList rscat.close set rscat = Nothing End Function Function displayImage(imgAttachArray, adID, tsize) If tsize = 0 Then tsize = 50 If Len(imgAttachArray) > 0 And Not isNull(imgAttachArray) Then imgTempArray = Split(imgAttachArray, sf) img = Split(imgTempArray(0), "|")(0) size = Split(imgTempArray(0), "|")(1) w = CLng(Split(size, "x")(0)) h = CLng(Split(size, "x")(1)) wa = w ha = h If wa > tsize then koef = wa / ha wa = tsize ha = Round(tsize / koef) End If If ha > tsize then koef = ha / wa ha = tsize wa = Round(tsize / koef) End If img_tb = gettf(img) If Not objFile.FileExists(uploadPATH & img_tb) then img_tb = img iid = RandomNumber imgStr = "
" & vbcrLf imgStr = imgStr & "" & vbcrLf imgStr = imgStr & "" & vbcrlf & "
" & vbcrLf Else: imgStr = NA End If displayImage = imgStr End Function Function checkEmpty(questionString) checkEmpty = questionString If isNull(questionString) Then checkEmpty = Empty End Function Function formatBody(adDescr) If instr(1,adDescr,"") adDescr = Replace(adDescr, vbcr, "
") adDescr = Replace(adDescr, chr(34), """) End If formatBody = adDescr End Function %> <% On Error Goto 0 '#### MODULE CONFIGURATION ################################################ '*** Limit ads body to specified number of characters if "fullbody=no" ad_body_limit = 600 '*** Limit number of ads to the value if no ads number specified in a query default_top_newads = 50 '*** Do not display over this limit default_max_newads = 50 '*** XML Content Encoding enc_type = "Windows-1252" '*** Display Site Logo (blogger might or might not display this) displayLogo = True '*** Specify Logo other than default site logo. Recommended if site default logo is a large image. Image must be located in "img" folder customLogo = "" '*** Time Zone (Abbereviations for your time zone are here: http://www.timeanddate.com/library/abbreviations/timezones/) TZ = "EST" '#### END MODULE CONFIGURATION ############################################# setLocale "1033" set rsconf = objConn.Execute("SELECT web_site,web_name,siteMetaDescr FROM " & tablPfx & "Config;") web_site = rsconf(0) web_name = "Rutland Trading Post Classifieds RSS Feed - Used Machines For Sale" siteMetaDescr = rsconf(2) rsconf.close topnew = Request("topnew") If isNumeric(topnew) And Len(CStr(topnew)) > 0 then If topnew < 1 And topnew > default_max_newads then topnew = default_top_newads Else: topnew = default_top_newads End If feed_category = Request("rccat") If Len(feed_category) > 0 And IsNumeric(feed_category) then IsChannelCategory = True If IsChannelCategory then site_url = web_site & "viewscat.asp?id=" & feed_category Else: site_url = web_site End If rc_user = Request("rcuid") If isNumeric(rc_user) And Len(CStr(rc_user)) = 6 then IsUserAds = tablPfx & "Ads.userID = " & CLng(rc_user) & " AND " RSS_OUT = "" RSS_OUT = RSS_OUT & "" RSS_OUT = RSS_OUT & "" RSS_OUT = RSS_OUT & "" & escme(web_name) & "" RSS_OUT = RSS_OUT & "" & site_url & "" RSS_OUT = RSS_OUT & "" & escme(siteMetaDescr) & "" If displayLogo then If Len(customLogo) = 0 then logo_image = logo Else logo_image = "img/" & customLogo End If RSS_OUT = RSS_OUT & "" RSS_OUT = RSS_OUT & "" & escme(web_name) & "" RSS_OUT = RSS_OUT & "" & web_site & logo_image & "" RSS_OUT = RSS_OUT & "" & web_site & "" RSS_OUT = RSS_OUT & "" End If If IsChannelCategory then If mysql then strSQL = "SELECT " & tablPfx & "Ads.*," & tablPfx & "Cat.catName FROM " & tablPfx & "Ads," & tablPfx & "Cat WHERE " strSQL = strSQL & "(" & IsUserAds & tablPfx & "Ads.catID = " & CLng(feed_category) & " AND " & tablPfx & "Ads.catID = " & tablPfx & "Cat.catID AND status = 1" strSQL = strSQL & hotads & epick & ") ORDER BY pdate DESC LIMIT 0," & topnew & ";" Else strSQL = "SELECT TOP " & topnew & " " & tablPfx & "Ads.*," & tablPfx & "Cat.catName FROM " & tablPfx & "Ads," & tablPfx & "Cat WHERE " strSQL = strSQL & "(" & IsUserAds & tablPfx & "Ads.catID = " & CLng(feed_category) & " AND " & tablPfx & "Cat.catID = " & tablPfx & "Ads.catID AND status = 1" strSQL = strSQL & hotads & epick & ") ORDER BY pdate DESC;" End If Else If mysql then strSQL = "SELECT " & tablPfx & "Ads.*," & tablPfx & "Cat.catName FROM " & tablPfx & "Ads," & tablPfx & "Cat WHERE " strSQL = strSQL & "(" & IsUserAds & tablPfx & "Ads.catID = " & tablPfx & "Cat.catID AND status = 1" strSQL = strSQL & hotads & epick & ") ORDER BY pdate DESC LIMIT 0," & topnew & ";" Else strSQL = "SELECT TOP " & topnew & " " & tablPfx & "Ads.*," & tablPfx & "Cat.catName FROM " & tablPfx & "Ads," & tablPfx & "Cat WHERE " strSQL = strSQL & "(" & IsUserAds & tablPfx & "Cat.catID = " & tablPfx & "Ads.catID AND status = 1" strSQL = strSQL & hotads & epick & ") ORDER BY pdate DESC;" End If End If d = 1 set rs = objConn.Execute(strSQL) If not rs.EOF then Set re = new RegExp re.global=true re.ignoreCase=true re.multiLine=true re.Pattern = "(<[^>]*>)|(" & vbCrLf & ")|(\s{2,})" Do While not rs.EOF adID = rs("adID") pdate = FormatRSSDate(rs("pdate")) subject = escme(rs("subject")) body = rs("body") body = Replace(body, "
", " ") On Error Resume Next If re.test(body) then body = re.replace(body, "") body = Replace(body, " ", " ") If Len(body) > ad_body_limit then body = Left(body, ad_body_limit) & " ..." body = escme(body) images = rs("images") If len(images) > 0 then imgTempArray = Split(images, sf) img = Split(imgTempArray(0), "|")(0) End If On Error GoTo 0 url_link = web_site & "viewad.asp?id=" & adID category = escme(rs("catName")) If IsChannelCategory And Len(category) > 0 And d = 1 then RSS_OUT = RSS_OUT & "" & category & "" RSS_OUT = RSS_OUT & "" RSS_OUT = RSS_OUT & "" & pdate & "" RSS_OUT = RSS_OUT & "" & subject & "" RSS_OUT = RSS_OUT & "" & body & "" If Not IsChannelCategory then RSS_OUT = RSS_OUT & "" & category & "" RSS_OUT = RSS_OUT & "" & url_link & "" If len(images) > 0 then If Right(lcase(img), 3) = "gif" then encType = "image/gif" Else: encType = "image/jpg" End If On Error Resume Next img_tb = gettf(img) If Not Server.CreateObject("Scripting.FileSystemObject").FileExists(server.mappath(upload) & "\" & img_tb) then img_tb = img encLen = Server.CreateObject("Scripting.FileSystemObject").GetFile(server.mappath(upload) & "\" & img_tb).size If err.number = 0 then RSS_OUT = RSS_OUT & "" On Error Goto 0 End If RSS_OUT = RSS_OUT & "" d = d + 1 rs.MoveNext Loop End If rs.close RSS_OUT = RSS_OUT & "
" Response.ContentType="text/xml" Response.Write RSS_OUT UpdateSessions False Function escme(str_in) escme = Replace(Replace(Replace(Replace(Replace(str_in, "&", "&"), ">", ">"), "<", "<"), "'", "'"), Chr(34), """) End Function Function FormatRSSDate(passDate) FormatRSSDate = WeekdayName(Weekday(passDate), True) & ", " & _ Right(DatePart("d", passDate) + 100, 2) & " " & _ MonthName(Month(passDate), True) & " " & Year(passDate) & " " & _ Right(DatePart("h", passDate) + 100, 2) & ":" & Right(DatePart("n", passDate) + 100, 2) & ":" & Right(DatePart("s", passDate) + 100, 2) & " " & TZ End Function %>