<% Dim MyConn, APPLICATION_URL, arrLEVEL, SAFE_EXTENSIONS_ONLY, KEEP_LOGS, DB_TO_USE, ALL_ARTICLES_PAGE_SIZE, SET_EMAIL_COMP, SHOW_AUTHOR Dim SEARCH_METHOD, SEARCH_IN, SEARCH_MODE, SEARCH_FOR, SMTP_AUTH, SMTP_USER, SMTP_PASS, SET_SMTP_SERVER, SET_SMTP_EMAIL Session.LCID = 1033 ' ------------------------------------------------- ' ' iNEWS PUBLISHER 3.0 ' ' Copyright © 2002-2008 Expinion.net ' ' http://www.expinion.net ' ' ------------------------------------------------- ' ' Set to URL where the application is installed, include the last back slash APPLICATION_URL = "http://www.waveplay.co.uk/news/" ' Email Component to use, chose one and assigned SET_EMAIL_COMP it's value. ' The last 3 contain different setting for CDOSYS component, try all until 1 works. '1 = AB Mailer '2 = Persits '3 = SMTPsvg '4 = CDONTS < Set as default '5 = CDO '6 = JMail '7 = Dundas '8 = CDOSYS - Windows 2003 Server '9 = CDOSYS - Windows 2003 Server '10 = CDOSYS - Windows 2003 Server SET_EMAIL_COMP = 8 ' Set to 1 if you are using MS Access, set to 2 if you are using MS SQL or MySQL database , 3 for MySQL DB_TO_USE = 1 ' Set to True to only allow "safe" files to be uploaded: (jpeg, jpg, gif, png, art, swf) ' Set to False to allow uploading of all files, including scripts (security risk) SAFE_EXTENSIONS_ONLY = True ' Set to True to keep activity logs for all agents ' Set to False to not to collect the activity logs KEEP_LOGS = True ' SET YOUR DATABASE CONNECTION SUB OPEN_DB() ' ... As entered by the set-up utility .................... Set MyConn = Server.CreateObject("ADODB.Connection") MyConn.Open "PROVIDER=Microsoft.Jet.OLEDB.4.0;DATA SOURCE=E:\DOMAINS\W\WAVEPLAY.CO.UK\USER\HTDOCS\NEWS\DB\iNP_30.mdb;" ' ......................................................... ' << MS Access Options >> ' DIRECT PATH 'Set MyConn = Server.CreateObject("ADODB.Connection") 'MyConn.Open "PROVIDER=Microsoft.Jet.OLEDB.4.0;DATA SOURCE=C:\Inetpub\wwwroot\NEWS\DB\iNP_30.mdb;" ' DSN CONNECTION 'Set MyConn = Server.CreateObject("ADODB.Connection") 'MyConn.open = "DSN=INP" ' MapPath CONNECTION 'Set MyConn = Server.CreateObject("ADODB.Connection") 'MyConn.Open "PROVIDER=Microsoft.Jet.OLEDB.4.0;Data Source=" & Server.MapPath("\path\NEWS\db\iNP_30.mdb") & ";Persist Security Info=False" ' << MS SQL Option >> ' MS-SQL CONNECTION 'Set MyConn = Server.CreateObject("ADODB.Connection") 'MyConn.Open "Provider=sqloledb;Network Library=DBMSSOCN;Data Source=MSSQLSERVER,1433;Initial Catalog=DATABASENAME;User ID=USERNAME;Password=PASSWORD;" ' << MySQL Option >> ' MySQL CONNECTION 'Set MyConn = Server.CreateObject("ADODB.Connection") 'MyConn.Open "Driver={MySQL ODBC 3.51 Driver}; Server=MYSQLSERVERADDRESS; uid=USERNAME; pwd=PASSWORD; database=DATABASENAME; option=3; port=3306;" END SUB ' ----- The following are settings that can be changed, however it's not necessary. ------------ ' ' Page size for the public side ALL_ARTICLES_PAGE_SIZE = 5 ' Set to True to show author of the article next to article title SHOW_AUTHOR = True ' Additional settings may be found within specific files. For example… ' Digg Voting Button can be turned on/off from the view.asp file (ALLOW_SOCIAL_NETWORKS setting). ' Public Article Suggestions can be turned on/off from the suggest.asp file. ' ---------------------------------------------------------------------------------------------- ' ' ----------------------------------NO NEED TO EDIT ANYTHING BELOW -------------------------------------- ' ' Assemble date value FUNCTION ASEMBLE_DATE_FORMAT(sDAY, sMONTH, sYEAR) Dim DATE_FORMAT, sDATE DATE_FORMAT = 1 ' US Locale SELECT CASE DATE_FORMAT CASE 1 sDATE = sMONTH & "/" & sDAY & "/" & sYEAR CASE ELSE sDATE = sMONTH & "/" & sDAY & "/" & sYEAR END SELECT ASEMBLE_DATE_FORMAT = sDATE END FUNCTION ' Email procedure PRIVATE SUB SEND_EMAIL_OUT(MSG, SUBJ, TO_EMAIL, FROM_EMAIL) ON ERROR RESUME NEXT Dim Mail, Jmail, MyCDONTSMail, Mailer, mailmsg, objMailer, objMailIIS6, objConfig, objMessage, Flds, objMail IF NOT (InStr(Lcase(TO_EMAIL), "@example.com") > 1) THEN SELECT CASE SET_EMAIL_COMP CASE 2 IF NOT (TO_EMAIL = "" OR IsNull(TO_EMAIL)) THEN Set Mail = Server.CreateObject("Persits.MailSender") With Mail .Host = SET_SMTP_SERVER .From = FROM_EMAIL .FromName = "iNews Publisher" .AddAddress TO_EMAIL IF NOT ATTACHE = "" THEN .AddAttachment ATTACHE END IF .Subject = SUBJ .IsHTML = True .Body = MSG IF SMTP_AUTH = "1" THEN .username = SMTP_USER .password = SMTP_PASS END IF On Error Resume Next .Send If Err <> 0 Then Response.Write "Error: " & Err.Description End If End With Set Mail = Nothing END IF CASE 3 IF NOT (TO_EMAIL = "" OR IsNull(TO_EMAIL)) THEN Set Mailer = Server.CreateObject("SMTPsvg.Mailer") With Mailer .FromName = Trim(Request.ServerVariables("SERVER_NAME")) .FromAddress = FROM_EMAIL .RemoteHost = SET_SMTP_SERVER .ContentType = "text/html" .AddRecipient "Recipient", TO_EMAIL .Subject = SUBJ .BodyText = MSG If Not .SendMail Then Response.Write "Error: " & .Response End If End With Set Mailer = Nothing END IF CASE 4 IF NOT (TO_EMAIL = "" OR IsNull(TO_EMAIL)) THEN Set MyCDONTSMail = CreateObject("CDONTS.NewMail") With MyCDONTSMail .BodyFormat = 0 .MailFormat = 0 .From = FROM_EMAIL .To = TO_EMAIL .Subject = SUBJ .Body = MSG .Send End With Set MyCDONTSMail=nothing END IF CASE 5 IF NOT (TO_EMAIL = "" OR IsNull(TO_EMAIL)) THEN Set mailmsg = Server.CreateObject("CDO.NewMail") With mailmsg .To = TO_EMAIL .From = FROM_EMAIL .Subject = SUBJ .HTMLBody = MSG .TextBody = MSG .Host = SET_SMTP_SERVER .Send End With Set mailmsg = Nothing END IF CASE 6 IF NOT (TO_EMAIL = "" OR IsNull(TO_EMAIL)) THEN Set Jmail = Server.CreateOBject("JMail.Message") With Jmail .Logging = true .Silent = true .From = FROM_EMAIL .AddRecipient TO_EMAIL .Subject = SUBJ .HTMLBody = MSG If .Send(SET_SMTP_SERVER) then If Err <> 0 Then Response.Write "Error: " & .log End If End If End With Set JMail = Nothing END IF CASE 7 IF NOT (TO_EMAIL = "" OR IsNull(TO_EMAIL)) THEN Set objMailer = Server.CreateObject("Dundas.Mailer") With objMailer .TOs.Add TO_EMAIL .FromAddress = FROM_EMAIL .Subject = SUBJ IF SMTP_AUTH = "1" THEN .User = SMTP_USER .Password = SMTP_PASS END IF .ContentType = "text/html" .Body = MSG .SendMail End With Set objMailer = Nothing END IF CASE 8 IF NOT (TO_EMAIL = "" OR IsNull(TO_EMAIL)) THEN Set objMessage = createobject("cdo.message") Set objConfig = createobject("cdo.configuration") Set Flds = objConfig.Fields Flds.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2 Flds.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = SET_SMTP_SERVER IF SMTP_AUTH = "1" THEN Flds.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1 Flds.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = SMTP_USER Flds.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = SMTP_PASS END IF Flds.update Set objMessage.Configuration = objConfig objMessage.HTMLBody = MSG objMessage.To = TO_EMAIL objMessage.From = FROM_EMAIL objMessage.Subject = SUBJ objMessage.TextBody = MSG objMessage.fields.update objMessage.Send Set objMessage = Nothing Set objConfig = Nothing END IF CASE 9 IF NOT (TO_EMAIL = "" OR IsNull(TO_EMAIL)) THEN Set objMailIIS6 = Server.CreateObject("CDO.Message") objMailIIS6.From = FROM_EMAIL objMailIIS6.To = TO_EMAIL objMailIIS6.HTMLBody = MSG objMailIIS6.Subject = SUBJ objMailIIS6.TextBody = MSG objMailIIS6.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2 objMailIIS6.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = SET_SMTP_SERVER objMailIIS6.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25 IF SMTP_AUTH = "1" THEN objMailIIS6.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1 objMailIIS6.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = SMTP_USER objMailIIS6.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = SMTP_PASS END IF objMailIIS6.Configuration.Fields.Update objMailIIS6.Send Set objMailIIS6 = Nothing END IF CASE 10 IF NOT (TO_EMAIL = "" OR IsNull(TO_EMAIL)) THEN Set objMailIIS6 = Server.CreateObject("CDO.Message") objMailIIS6.From = FROM_EMAIL objMailIIS6.To = TO_EMAIL objMailIIS6.HTMLBody = MSG objMailIIS6.Subject = SUBJ objMailIIS6.TextBody = MSG objMailIIS6.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/sendusing") = 1 ' Can also be set to 2 objMailIIS6.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/smtpserver") = SET_SMTP_SERVER objMailIIS6.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25 objMailIIS6.Configuration.Fields.item("http://schemas.microsoft.com/cdo/configuration/smtpserverpickupdirectory") = "C:\Program Files\Exchsrvr\Mailroot\vsi 1\Pickup" IF SMTP_AUTH = "1" THEN objMailIIS6.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1 objMailIIS6.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = SMTP_USER objMailIIS6.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = SMTP_PASS END IF objMailIIS6.Configuration.Fields.Update objMailIIS6.Send Set objMailIIS6 = Nothing END IF END SELECT END IF SELECT CASE Err.Number CASE -2147220973 Response.write "Emailing Error: " & Err.Description & "
" Response.write "Make sure the SMTP as set under Tools > Settings (" & SET_SMTP_SERVER & ") is correct." Response.End CASE 2147220975 Response.write "Emailing Error: " & Err.Description & "
" Response.write "Make sure the SMTP username & password as set under Tools > Settings are correct." Response.End END SELECT END SUB %> <% '// NO NEED TO MODIFY ANYTHING BELOW FUNCTION CNT_DATE(sDATE) IF IsDate(sDATE) = True THEN SELECT CASE DATE_FORMAT CASE 1 'YYYYMMDD CNT_DATE = Year(sDATE) & Right(Cstr(Month(sDATE) + 100),2) & Right(Cstr(Day(sDATE) + 100),2) CASE 2 'YYYY-MM-DD CNT_DATE = Year(sDATE) & "-" & Right(Cstr(Month(sDATE) + 100),2) & "-" & Right(Cstr(Day(sDATE) + 100),2) CASE 101 'mm/dd/yy CNT_DATE = Right(Cstr(Month(sDATE) + 100),2) & "/" & Right(Cstr(Day(sDATE) + 100),2) & "/" & Right(Cstr(Year(sDATE)),2) CASE 102 'yy.mm.dd CNT_DATE = Right(Cstr(Year(sDATE)),2) & "." & Right(Cstr(Month(sDATE) + 100),2) & "." & Right(Cstr(Day(sDATE) + 100),2) CASE 103 'dd/mm/yy CNT_DATE = Right(Cstr(Day(sDATE) + 100),2) & "/" & Right(Cstr(Month(sDATE) + 100),2) & "/" & Right(Cstr(Year(sDATE)),2) CASE 104 'dd.mm.yy CNT_DATE = Right(Cstr(Day(sDATE) + 100),2) & "." & Right(Cstr(Month(sDATE) + 100),2) & "." & Right(Cstr(Year(sDATE)),2) CASE 105 'dd-mm-yy CNT_DATE = Right(Cstr(Day(sDATE) + 100),2) & "-" & Right(Cstr(Month(sDATE) + 100),2) & "-" & Right(Cstr(Year(sDATE)),2) CASE 110 'mm-dd-yy CNT_DATE = Right(Cstr(Month(sDATE) + 100),2) & "-" & Right(Cstr(Day(sDATE) + 100),2) & "-" & Right(Cstr(Year(sDATE)),2) CASE 111 'yy/mm/dd CNT_DATE = Right(Cstr(Year(sDATE)),2) & "/" & Right(Cstr(Month(sDATE) + 100),2) & "/" & Right(Cstr(Day(sDATE) + 100),2) CASE 112 'yymmdd CNT_DATE = Right(Cstr(Year(sDATE)),2) & Right(Cstr(Month(sDATE) + 100),2) & Right(Cstr(Day(sDATE) + 100),2) END SELECT ELSE CNT_DATE = Null END IF END FUNCTION SUB POPULATE_SMTP_INFO() SQL = "SELECT fldAUTH, fldUSER, fldPASS, fldSMTP, fldEMAIL FROM nm_tbl_settings WHERE ID = 1" Set RS = Server.CreateObject("ADODB.Recordset") RS.LockType = 1 RS.CursorType = 0 RS.Open SQL, MyConn IF NOT RS.EOF THEN SMTP_AUTH = trim(RS("fldAUTH")) SMTP_USER = trim(RS("fldUSER")) SMTP_PASS = trim(RS("fldPASS")) SET_SMTP_SERVER = trim(RS("fldSMTP")) SET_SMTP_EMAIL = trim(RS("fldEMAIL")) END IF RS.Close Set RS = Nothing END SUB %> <% FUNCTION CONVERT_TO_HEX_STRING(VAL) Dim I, TMP_S, HEX_STR, STR_CHAR TMP_S = VAL FOR I = 1 TO Len(TMP_S) STR_CHAR = Mid(TMP_S,I,1) HEX_STR = HEX_STR & "%" & Hex(Asc(STR_CHAR)) NEXT CONVERT_TO_HEX_STRING = HEX_STR END FUNCTION FUNCTION GENERATE_CHAR_CAPTCHA(iLEN) Dim intCounter, intDecimal, strSTRING For intCounter = 1 To Cint(iLEN) Randomize() intDecimal = Int((26 * Rnd) + 1) + 64 strSTRING = strSTRING & Chr(intDecimal) Next GENERATE_CHAR_CAPTCHA = UCASE(strSTRING) END FUNCTION '// REPLACES INVALID CHARS FROM STRING TO BE PASSED INTO JavaScript '// REPLACES THE FOLLOWING CHARS: "-'-(-) with `-`-[-`] FUNCTION FIX_JS_STR(val) Dim TMP_VAL TMP_VAL = val If Len(TMP_VAL) > 0 Then TMP_VAL = Replace(TMP_VAL,chr(34),""") TMP_VAL = Replace(TMP_VAL,"'","`") TMP_VAL = Replace(TMP_VAL,"(","[") TMP_VAL = Replace(TMP_VAL,")","]") End IF FIX_JS_STR = TMP_VAL END FUNCTION '// CHECK IF THE BROWSER IS MSIE '// Returns True if MSIE false if anything else FUNCTION IsMSIE() IsMSIE = True 'If Instr(Ucase(Request.ServerVariables("HTTP_USER_AGENT")), "MSIE") Then ' IsMSIE = True 'Else ' IsMSIE = False 'End if END FUNCTION '// ENCRYPTS STRING SUCH AS PASSWORD '// Returns encrypted string such as: BTEGE^J] to password FUNCTION EnCrypt(strCryptThis) Dim strChar, iKeyChar, iStringChar, i for i = 1 to Len(strCryptThis) iKeyChar = Asc(mid("2564218975223456482120840",i,1)) iStringChar = Asc(mid(strCryptThis,i,1)) iCryptChar = iKeyChar Xor iStringChar strEncrypted = strEncrypted & Chr(iCryptChar) next EnCrypt = strEncrypted END FUNCTION '// DECRYPT STRING SUCH AS PASSWORD '// Returns decrypted string such as: password to BTEGE^J] FUNCTION DeCrypt(strEncrypted) Dim strChar, iKeyChar, iStringChar, i for i = 1 to Len(strEncrypted) iKeyChar = (Asc(mid("2564218975223456482120840",i,1))) iStringChar = Asc(mid(strEncrypted,i,1)) iDeCryptChar = iKeyChar Xor iStringChar strDecrypted = strDecrypted & Chr(iDeCryptChar) next DeCrypt = strDecrypted END FUNCTION PRIVATE FUNCTION APO(val) Dim tmpSTR tmpSTR = val IF NOT tmpSTR = "" THEN tmpSTR = Replace(Trim(tmpSTR),chr(34),""") tmpSTR = Replace(Trim(tmpSTR),"'","''") tmpSTR = Replace(Trim(tmpSTR),"<","<") tmpSTR = Replace(Trim(tmpSTR),">",">") IF DB_TO_USE = 3 THEN tmpSTR = Replace(Trim(tmpSTR),"\","\\") END IF APO = tmpSTR END FUNCTION PRIVATE FUNCTION APO_LAX(val) Dim strRES strRES = Replace(Trim(val),"'","''") IF DB_TO_USE = 3 THEN strRES = Replace(Trim(strRES),"\","\\") APO_LAX = strRES END FUNCTION PRIVATE FUNCTION APO_INJ(val) Dim tmpSTR tmpSTR = val IF NOT tmpSTR = "" THEN tmpSTR = Replace(Trim(tmpSTR),chr(34),""") tmpSTR = Replace(Trim(tmpSTR),"<","<") tmpSTR = Replace(Trim(tmpSTR),">",">") IF DB_TO_USE = 3 THEN tmpSTR = Replace(Trim(tmpSTR),"\","\\") END IF APO_INJ = tmpSTR END FUNCTION '// CONVERT VALEU TO EITHER 1 OR 0 '// Convert "1" to 1 ; Convert "X" to 0 FUNCTION CONVERT_NUM(val) IF Trim(val) = "1" THEN CONVERT_NUM = 1 ELSE CONVERT_NUM = 0 END IF END FUNCTION '// CONVERT VALUE FROM NUMERIC TO WORDS '// Convert "1" to Yes ; Convert "X" to No FUNCTION CONVERT_TXT(val) IF Trim(Cstr(val & "")) = "1" THEN CONVERT_TXT = "Yes" ELSE CONVERT_TXT = "No" END IF END FUNCTION '// STRIP HTML TAGS FROM TEXT '// Returns modified content. FUNCTION STRIP_CODE(strText) Dim RegEx Set RegEx = New RegExp RegEx.Pattern = "<[^>]*>" RegEx.Global = True STRIP_CODE = RegEx.Replace(strText, "") Set RegEx = Nothing END FUNCTION '// PROCESSES THE TEXT FOR ANY URL OR EMAIL STRINGS '// MAKE ALL URLS AND EMAILS CLICKABLE IN THE TEXT '// Returns modified content. FUNCTION LinkURLS(ByRef asContent) '// Regular Expression Object (Requires vbScript 5.0 and above) On Error Resume Next Dim loRegExp if asContent = "" Then Exit function Set loRegExp = New RegExp loRegExp.Global = True loRegExp.IgnoreCase = True loRegExp.Pattern = "((ht|f)tps?://\S+[/]?[^\.])([\.]?.*)" LinkURLs = loRegExp.Replace(asContent, "$1$3") loRegExp.Pattern = "(\S+@\S+.\.\S\S\S?)" LinkURLs = loRegExp.Replace(LinkURLs, "$1") Set loRegExp = Nothing END FUNCTION '// CHECK THAT WE HAVE VALID EMAIL ADDRESS '// Returns True if valid, False is not PRIVATE FUNCTION IsEmailValid(strEmail) Dim strArray, strItem, i, c, blnIsItValid blnIsItValid = True strArray = Split(strEmail, "@") If UBound(strArray) <> 1 Then blnIsItValid = False IsEmailValid = blnIsItValid Exit Function End If For Each strItem In strArray If Len(strItem) <= 0 Then blnIsItValid = False IsEmailValid = blnIsItValid Exit Function End If For i = 1 To Len(strItem) c = LCase(Mid(strItem, i, 1)) If InStr("abcdefghijklmnopqrstuvwxyz_-.", c) <= 0 And Not IsNumeric(c) Then blnIsItValid = False IsEmailValid = blnIsItValid Exit Function End If Next If Left(strItem, 1) = "." Or Right(strItem, 1) = "." Then blnIsItValid = False IsEmailValid = blnIsItValid Exit Function End If Next If InStr(strArray(1), ".") <= 0 Then blnIsItValid = False IsEmailValid = blnIsItValid Exit Function End If i = Len(strArray(1)) - InStrRev(strArray(1), ".") If i < 2 Then blnIsItValid = False IsEmailValid = blnIsItValid Exit Function End If If InStr(strEmail, "..") > 0 Then blnIsItValid = False IsEmailValid = blnIsItValid Exit Function End If IsEmailValid = blnIsItValid END FUNCTION ' Format Phone Number FUNCTION FORMAT_PHONE(strP) Dim regEX Set regEX = New RegExp regEX.Pattern = "(\d{3})(\d{3})(\d{4})" FORMAT_PHONE = regEX.Replace(strP, "($1) $2-$3") Set regEX = Nothing END FUNCTION ' Ensure non vionlent entry PRIVATE FUNCTION TURBO_INJECTION(strWords) Dim badChars, newChars, I badChars = array("select", "drop", ";", "--", "insert", "delete", "xp_", ">XSS") newChars = strWords FOR I = 0 to Ubound(badChars) newChars = Replace(newChars, badChars(I), "") NEXT newChars = Replace(newChars,"'","''") TURBO_INJECTION = newChars END FUNCTION ' Check that the given ID is valid PRIVATE FUNCTION IS_VALID_ID(sID) IF Trim(sID) = "" OR IsNUll(sID) THEN IS_VALID_ID = False ELSE If Instr(sID,",") >=1 OR Instr(sID,".") >=1 THEN IS_VALID_ID = False Else If IsNumeric(sID) = True Then IS_VALID_ID = True Else IS_VALID_ID = False End If End If END IF END FUNCTION ' Check that the given file exists FUNCTION IsFILE(strPATH) If strPATH = "" Then IsFILE = False Exit Function End If Dim objFSO Set objFSO = Server.CreateObject("Scripting.FileSystemObject") If (objFSO.FileExists(strPATH)) = True Then IsFILE = True Else IsFILE = False End If Set objFSO = Nothing End FUNCTION ' replace some chars in XML FUNCTION PREPARE_XML(strVAL) strVAL = Replace(strVAL,"<","<") strVAL = Replace(strVAL,">",">") strVAL = Replace(strVAL,"&","&") strVAL = Replace(strVAL,"’","'") strVAL = Replace(strVAL,"‘","'") strVAL = Replace(strVAL,"…","...") strVAL = Replace(strVAL,"”","'") strVAL = Replace(strVAL,"“","'") strVAL = Trim(strVAL) PREPARE_XML = strVAL END FUNCTION ' Process desired text content for image shortcuts FUNCTION PROCESS_SHORTCUTS(blOPEN, TEXT) Dim SQL, RS, strRETURNED_DATA, EOF_VAL, intNUM_COL, intNUM_ROW, intROW_COUNTER, strSIGN, strIMAGE IF blOPEN = True THEN Call OPEN_DB() END IF SQL = "SELECT fldSIGN, fldIMAGE FROM nm_tbl_library WHERE fldACTIVE = 1" Set RS = Server.CreateObject("ADODB.Recordset") RS.LockType = 1 RS.CursorType = 0 RS.Open SQL, MyConn IF NOT RS.EOF THEN strRETURNED_DATA = RS.getrows ELSE EOF_VAL = True END IF RS.close Set RS = Nothing IF blOPEN = True THEN MyConn.Close Set MyConn = Nothing END IF IF Not EOF_VAL = True Then intNUM_COL=ubound(strRETURNED_DATA,1) intNUM_ROW=ubound(strRETURNED_DATA,2) FOR intROW_COUNTER = 0 TO intNUM_ROW strSIGN = Trim(strRETURNED_DATA(0,intROW_COUNTER)) strIMAGE = Trim(strRETURNED_DATA(1,intROW_COUNTER)) strIMAGE = "" TEXT = Replace(TEXT, strSIGN, strIMAGE) NEXT END IF PROCESS_SHORTCUTS = TEXT END FUNCTION ' Get desired setting value for the application FUNCTION GET_SETTINGS(blOPEN, fldNAME) Dim SQL, RS IF blOPEN = True THEN Call OPEN_DB() END IF SQL = "SELECT " & fldNAME & " FROM nm_tbl_settings WHERE ID = 1" Set RS = Server.CreateObject("ADODB.Recordset") RS.LockType = 1 RS.CursorType = 0 RS.Open SQL, MyConn IF NOT RS.EOF THEN GET_SETTINGS = trim(RS(fldNAME)) ELSE GET_SETTINGS = "" END IF RS.Close Set RS = Nothing IF blOPEN = True THEN MyConn.Close Set MyConn = Nothing END IF END FUNCTION ' Append desired log record FUNCTION APPEND_LOG(blOPEN, strLOGLINE, intID) Dim SQL, tmpLOG IF KEEP_LOGS = True THEN IF blOPEN = True THEN Call OPEN_DB() END IF tmpLOG = strLOGLINE tmpLOG = APO(tmpLOG) IF Len(tmpLOG) > 150 THEN tmpLOG = mid(tmpLOG,1,150) SQL = "INSERT INTO nm_tbl_logs (fldLOG, fldAID) VALUES ('" & tmpLOG & "'," & intID & ")" MyConn.Execute SQL IF blOPEN = True THEN MyConn.Close Set MyConn = Nothing END IF END IF END FUNCTION ' Split the security levels into an array FUNCTION CREATE_SECURITY() arrLEVEL = Split(Session("LEVEL"),",") END FUNCTION ' Count articles for the public side FUNCTION NEWS_COUNTER(VAL_ID) Dim SQL, RS IF DB_TO_USE = 1 OR DB_TO_USE = 3 THEN SQL = "SELECT COUNT(ID) AS C_COUNT FROM nm_tbl_news_cate WHERE (fldNEWS_ID IN (SELECT ID FROM nm_tbl_news WHERE (fldACTIVE = 1) AND (Now() BETWEEN fldPOSTED AND fldEXPIRES))) AND nm_tbl_news_cate.fldCATE_ID = " & VAL_ID ELSE SQL = "SELECT COUNT(ID) AS C_COUNT FROM nm_tbl_news_cate WHERE (fldNEWS_ID IN (SELECT ID FROM nm_tbl_news WHERE (fldACTIVE = 1) AND (GetDate() BETWEEN fldPOSTED AND fldEXPIRES))) AND nm_tbl_news_cate.fldCATE_ID = " & VAL_ID END IF Set RS = Server.CreateObject("ADODB.Recordset") RS.LockType = 1 RS.CursorType = 0 RS.Open SQL, MyConn IF NOT RS.EOF THEN NEWS_COUNTER = trim(RS("C_COUNT")) ELSE NEWS_COUNTER = "0" END IF RS.Close Set RS = Nothing END FUNCTION FUNCTION CREATE_LINK() Dim TMP SELECT CASE LEVEL CASE "1" TMP = "category_nested.asp?PID=" & CID & "&level=2" CASE "2" TMP = "category_nested.asp?PID=" & CPID & "&SID=" & CID & "&level=3" CASE "3" TMP = "category_nested.asp?PID=" & CPID & "&SID=" & CSID & "&level=4" & "&fID=" & CID END SELECT CREATE_LINK = TMP END FUNCTION FUNCTION GET_NAME(SQL_MY) Dim RS Set RS = Server.CreateObject("ADODB.Recordset") RS.LockType = 1 RS.CursorType = 0 RS.Open SQL_MY, MyConn IF NOT RS.EOF THEN GET_NAME = trim(RS("fldNAME")) ELSE GET_NAME = "" END IF RS.Close Set RS = Nothing END FUNCTION FUNCTION RFC822(dDate,iOffset) Dim d d = DateAdd("h",-iOffset,dDate) RFC822 = Left(WeekDayName(WeekDay(d)),3) & ", " & Right(String(2,"0") & Day(d),2) & " " & Left(MonthName(Month(d)),3) & " " & Year(d) & " " & Right(String(2,"0") & Hour(d),2) & ":" & Right(String(2,"0") & Minute(d),2) & ":" & Right(String(2,"0") & Second(d),2) & " " & "GMT" END FUNCTION PRIVATE FUNCTION GET_CATES(NID) Dim SQL, RS, strRES SQL = "SELECT ID, fldNAME FROM nm_tbl_cate WHERE ID IN (SELECT fldCATE_ID FROM nm_tbl_news_cate WHERE fldNEWS_ID = " & NID & ")" Set RS = Server.CreateObject("ADODB.Recordset") RS.LockType = 1 RS.CursorType = 0 RS.Open SQL, MyConn WHILE NOT RS.EOF strRES = strRES & "" & trim(RS("fldNAME")) & ", " RS.MoveNext WEND RS.Close Set RS = Nothing IF NOT (strRES = "" OR IsnUll(strRES)) THEN strRES = Mid(strRES,1, Len(strRES)-2) GET_CATES = strRES END FUNCTION FUNCTION PRODUCE_PAGE_DETAILS(ARTICLE_ID) Dim SQL, RS, TITLE, DES, KEY, strRES SQL = "SELECT fldMETA_TITLE, fldMETA_DES, fldMETA_KEY FROM nm_tbl_news WHERE ID = " & ARTICLE_ID Call OPEN_DB() Set RS = Server.CreateObject("ADODB.Recordset") RS.LockType = 1 RS.CursorType = 0 RS.Open SQL, MyConn IF NOT RS.EOF THEN TITLE = trim(RS("fldMETA_TITLE")) DES = trim(RS("fldMETA_DES")) KEY = trim(RS("fldMETA_KEY")) END IF RS.Close Set RS = Nothing MyConn.Close Set MyConn = Nothing strRES = strRES & Vbcrlf & "" & TITLE & "" & Vbcrlf strRES = strRES & "" & Vbcrlf strRES = strRES & "" & Vbcrlf PRODUCE_PAGE_DETAILS = strRES END FUNCTION %> <% Dim SQL, RS, NID, TITLE, POSTED, NEWS_LISTING, I_RSS, SUMMARY, RSS_BUILD, TOP_X, X, MODEX, CID MODEX = APO(Request.QueryString("mode")) CID = APO(Request.QueryString("cid")) TOP_X = Trim(Request.QueryString("top")) IF IS_VALID_ID(CID) = False AND MODEX = "cate" THEN MODEX = "" IF IS_VALID_ID(TOP_X) = False THEN TOP_X = 25 ELSE TOP_X = Cint(TOP_X) END IF RSS_BUILD = RSS_BUILD & "" & vbcrlf RSS_BUILD = RSS_BUILD & "" & vbcrlf RSS_BUILD = RSS_BUILD & " " & vbcrlf RSS_BUILD = RSS_BUILD & " Top Stories" & vbcrlf RSS_BUILD = RSS_BUILD & " " & APPLICATION_URL & "" & vbcrlf RSS_BUILD = RSS_BUILD & " News - Top Stories" & vbcrlf RSS_BUILD = RSS_BUILD & " iNews Publisher, developed by Expinion.net - RSS" & vbcrlf RSS_BUILD = RSS_BUILD & " en-us" & vbcrlf RSS_BUILD = RSS_BUILD & " " & RFC822(Now(),0) & "" & vbcrlf IF DB_TO_USE = 1 OR DB_TO_USE = 3 THEN ' MS Access SELECT CASE Lcase(MODEX) CASE "recent" ' Most recent SQL = "SELECT nm_tbl_news.ID AS NID, nm_tbl_news.fldTITLE AS TITLE, nm_tbl_news.fldPOSTED AS POSTED, fldSUMMARY FROM nm_tbl_news, nm_tbl_agent WHERE (nm_tbl_agent.ID = nm_tbl_news.fldAID) AND (nm_tbl_news.fldACTIVE=1) AND (Now() BETWEEN fldPOSTED AND fldEXPIRES) ORDER BY fldPOSTED DESC" CASE "pop" ' Most accessed SQL = "SELECT nm_tbl_news.ID AS NID, nm_tbl_news.fldTITLE AS TITLE, nm_tbl_news.fldPOSTED AS POSTED, fldSUMMARY FROM nm_tbl_news, nm_tbl_agent WHERE (nm_tbl_agent.ID = nm_tbl_news.fldAID) AND (nm_tbl_news.fldACTIVE=1) AND (Now() BETWEEN fldPOSTED AND fldEXPIRES) ORDER BY fldVIEWS DESC" CASE "all" ' All articles SQL = "SELECT nm_tbl_news.ID AS NID, nm_tbl_news.fldTITLE AS TITLE, nm_tbl_news.fldPOSTED AS POSTED, fldSUMMARY FROM nm_tbl_news, nm_tbl_agent WHERE (nm_tbl_agent.ID = nm_tbl_news.fldAID) AND (nm_tbl_news.fldACTIVE=1) AND (Now() BETWEEN fldPOSTED AND fldEXPIRES) ORDER BY fldPOSTED DESC" CASE "highlighted" SQL = "SELECT nm_tbl_news.ID AS NID, nm_tbl_news.fldTITLE AS TITLE, nm_tbl_news.fldPOSTED AS POSTED, fldSUMMARY FROM nm_tbl_news, nm_tbl_agent WHERE (nm_tbl_agent.ID = nm_tbl_news.fldAID) AND (nm_tbl_news.fldACTIVE=1) AND (Now() BETWEEN fldPOSTED AND fldEXPIRES) AND (fldHIGHLIGHT = 1) ORDER BY fldPOSTED DESC" CASE "cate" SQL = "SELECT nm_tbl_news.ID AS NID, nm_tbl_news.fldTITLE AS TITLE, nm_tbl_news.fldPOSTED AS POSTED, fldSUMMARY FROM nm_tbl_news, nm_tbl_agent WHERE (nm_tbl_agent.ID = nm_tbl_news.fldAID) AND (nm_tbl_news.fldACTIVE=1) AND (Now() BETWEEN fldPOSTED AND fldEXPIRES) AND (nm_tbl_news.ID IN (SELECT fldNEWS_ID FROM nm_tbl_news_cate WHERE fldCATE_ID = " & CID & ")) ORDER BY fldPOSTED DESC" CASE ELSE ' Any other mode not listed above SQL = "SELECT nm_tbl_news.ID AS NID, nm_tbl_news.fldTITLE AS TITLE, nm_tbl_news.fldPOSTED AS POSTED, fldSUMMARY FROM nm_tbl_news, nm_tbl_agent WHERE (nm_tbl_agent.ID = nm_tbl_news.fldAID) AND (nm_tbl_news.fldACTIVE=1) AND (Now() BETWEEN fldPOSTED AND fldEXPIRES) ORDER BY fldPOSTED DESC" END SELECT ELSE SELECT CASE Lcase(MODEX) CASE "recent" ' Most recent SQL = "SELECT nm_tbl_news.ID AS NID, nm_tbl_news.fldTITLE AS TITLE, nm_tbl_news.fldPOSTED AS POSTED, fldSUMMARY FROM nm_tbl_news, nm_tbl_agent WHERE (nm_tbl_agent.ID = nm_tbl_news.fldAID) AND (nm_tbl_news.fldACTIVE=1) AND (GetDate() BETWEEN fldPOSTED AND fldEXPIRES) ORDER BY fldPOSTED DESC" CASE "pop" ' Most accessed SQL = "SELECT nm_tbl_news.ID AS NID, nm_tbl_news.fldTITLE AS TITLE, nm_tbl_news.fldPOSTED AS POSTED, fldSUMMARY FROM nm_tbl_news, nm_tbl_agent WHERE (nm_tbl_agent.ID = nm_tbl_news.fldAID) AND (nm_tbl_news.fldACTIVE=1) AND (GetDate() BETWEEN fldPOSTED AND fldEXPIRES) ORDER BY fldVIEWS DESC" CASE "all" ' All articles SQL = "SELECT nm_tbl_news.ID AS NID, nm_tbl_news.fldTITLE AS TITLE, nm_tbl_news.fldPOSTED AS POSTED, fldSUMMARY FROM nm_tbl_news, nm_tbl_agent WHERE (nm_tbl_agent.ID = nm_tbl_news.fldAID) AND (nm_tbl_news.fldACTIVE=1) AND (GetDate() BETWEEN fldPOSTED AND fldEXPIRES) ORDER BY fldPOSTED DESC" CASE "highlighted" SQL = "SELECT nm_tbl_news.ID AS NID, nm_tbl_news.fldTITLE AS TITLE, nm_tbl_news.fldPOSTED AS POSTED, fldSUMMARY FROM nm_tbl_news, nm_tbl_agent WHERE (nm_tbl_agent.ID = nm_tbl_news.fldAID) AND (nm_tbl_news.fldACTIVE=1) AND (GetDate() BETWEEN fldPOSTED AND fldEXPIRES) AND (fldHIGHLIGHT = 1) ORDER BY fldPOSTED DESC" CASE "cate" SQL = "SELECT nm_tbl_news.ID AS NID, nm_tbl_news.fldTITLE AS TITLE, nm_tbl_news.fldPOSTED AS POSTED, fldSUMMARY FROM nm_tbl_news, nm_tbl_agent WHERE (nm_tbl_agent.ID = nm_tbl_news.fldAID) AND (nm_tbl_news.fldACTIVE=1) AND (GetDate() BETWEEN fldPOSTED AND fldEXPIRES) AND (nm_tbl_news.ID IN (SELECT fldNEWS_ID FROM nm_tbl_news_cate WHERE fldCATE_ID = " & CID & ")) ORDER BY fldPOSTED DESC" CASE ELSE ' Any other mode not listed above SQL = "SELECT nm_tbl_news.ID AS NID, nm_tbl_news.fldTITLE AS TITLE, nm_tbl_news.fldPOSTED AS POSTED, fldSUMMARY FROM nm_tbl_news, nm_tbl_agent WHERE (nm_tbl_agent.ID = nm_tbl_news.fldAID) AND (nm_tbl_news.fldACTIVE=1) AND (GetDate() BETWEEN fldPOSTED AND fldEXPIRES) ORDER BY fldPOSTED DESC" END SELECT END IF X = 0 Call OPEN_DB() Set RS = Server.CreateObject("ADODB.Recordset") RS.LockType = 1 RS.CursorType = 0 RS.Open SQL, MyConn WHILE NOT RS.EOF X = X + 1 IF Cint(X) =< TOP_X THEN NID = PREPARE_XML(RS("NID")) TITLE = PREPARE_XML(RS("TITLE")) POSTED = PREPARE_XML(RS("POSTED")) SUMMARY = PREPARE_XML(RS("fldSUMMARY")) RSS_BUILD = RSS_BUILD & "" & vbcrlf RSS_BUILD = RSS_BUILD & " " & PROCESS_SHORTCUTS_RSS(False, TITLE) & "" & vbcrlf RSS_BUILD = RSS_BUILD & " " & PREPARE_XML(APPLICATION_URL) & "view.asp?ID=" & NID & "" & vbcrlf RSS_BUILD = RSS_BUILD & " " & RFC822(POSTED,0) & "" & vbcrlf RSS_BUILD = RSS_BUILD & " " & PROCESS_SHORTCUTS_RSS(False, SUMMARY) & "" & vbcrlf RSS_BUILD = RSS_BUILD & "" & vbcrlf END IF RS.MoveNext WEND RS.Close Set RS = Nothing MyConn.Close Set MyConn = Nothing RSS_BUILD = RSS_BUILD & " " & vbcrlf RSS_BUILD = RSS_BUILD & "" & vbcrlf RSS_BUILD = RSS_BUILD & "" & vbcrlf FUNCTION PROCESS_SHORTCUTS_RSS(blOPEN, TEXT) Dim SQL, RS, strRETURNED_DATA, EOF_VAL, intNUM_COL, intNUM_ROW, intROW_COUNTER, strSIGN, strIMAGE SQL = "SELECT fldSIGN, fldIMAGE FROM nm_tbl_library WHERE fldACTIVE = 1" Set RS = Server.CreateObject("ADODB.Recordset") RS.LockType = 1 RS.CursorType = 0 RS.Open SQL, MyConn IF NOT RS.EOF THEN strRETURNED_DATA = RS.getrows ELSE EOF_VAL = True END IF RS.close Set RS = Nothing IF Not EOF_VAL = True Then intNUM_COL=ubound(strRETURNED_DATA,1) intNUM_ROW=ubound(strRETURNED_DATA,2) FOR intROW_COUNTER = 0 TO intNUM_ROW strSIGN = Trim(strRETURNED_DATA(0,intROW_COUNTER)) strIMAGE = Trim(strRETURNED_DATA(1,intROW_COUNTER)) TEXT = Replace(TEXT, strSIGN, "") NEXT END IF PROCESS_SHORTCUTS_RSS = TEXT END FUNCTION With Response .Buffer = True .ContentType = "text/xml" .write(RSS_BUILD) End With %>