<% Option Explicit %> <% '**************************************************************************************** '** Copyright Notice '** '** Web Wiz Mailing List '** http://www.webwizmailinglist.com '** '** Copyright ©2002-2006 Web Wiz. All Rights Reserved. '** '** THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS UNDER LICENSE FROM 'WEB WIZ'. '** '** IF YOU DO NOT AGREE TO THE LICENSE AGREEMENT THEN 'WEB WIZ' IS UNWILLING TO LICENSE '** THE SOFTWARE TO YOU, AND YOU SHOULD DESTROY ALL COPIES YOU HOLD OF 'WEB WIZ' SOFTWARE '** AND DERIVATIVE WORKS IMMEDIATELY. '** '** If you have not received a copy of the license with this work then a copy of the latest '** license contract can be found at:- '** '** http://www.webwizguide.com/license '** '** For more information about this software and for licensing information please contact '** 'Web Wiz' at the address and website below:- '** '** Web Wiz, Unit 10E, Dawkins Road Industrial Estate, Poole, Dorset, BH15 4JD, England '** http://www.webwizguide.com '** '** Removal or modification of this copyright notice will violate the license contract. '** '**************************************************************************************** 'Make the session timeout 20 minutes (this is overridden in a few files) Session.Timeout = 20 Dim adoCon 'Database Connection Variable Dim strAccessDB 'Holds the Access Database Name Dim rsCommon 'Holds the configuartion recordset Dim strCon 'Holds the Database driver and the path and name of the database Dim strSQL 'Holds the SQL query for the database Dim strWebsiteName 'Holds the website name Dim strWebsiteAddress 'Holds the website URL and path to the script Dim strWebsiteEmailAddress 'Holds the forum e-mail address Dim strTestEmailAddress 'holds the e-mail address the preview e-mail is sent to Dim strMailComponent 'Email coponent the mailing list useses Dim strMailServer 'Website's outgoing SMTP mail server Dim strMailServerUser 'SMTP server user name Dim strMailServerPass 'SMTP server password Dim blnLCode 'set to true Dim strWelcomeEmailSub 'Holds the subject of the welcome email Dim strWelcomeEmailHTML 'Holds the welcome message that is sent to users (HTML format) Dim strWelcomeEmailText 'Holds the welcome message that is sent to users (plain text format) Dim strDbPathAndName 'Holds the path and name to the database Dim blnActivate 'Set to true if email activation is enabled Dim blnPlainTextOption 'Set to true if the user has a choice of a plain text email format Dim blnEncryptPasswords 'Set to true if passwords are encrypted Dim blnJoinNotify 'Set to true if the admin wants to be notifies of new subscriptions Dim blnRemoveNotify 'Set to trus if the admin wants to be notified of poeple leaving Dim strTitleImage 'Holds the location of the title image Dim strUploadComponent 'Holds the upload component Dim strFileUploadPath 'Holds the upload path Dim strFileTypes 'Holds the upload file types Dim strImageTypes 'Holds the upload image types Dim strDBFalse 'Holds the fales database value Dim strDBTrue 'Holds the true database value Dim strDatabaseDateFunction 'Holds the date function Dim strPrivacyStatment 'Holds the privacy statment for the mailing list Dim strSignature 'Holds custom signature Dim blnAbout 'Initiliase varibales Const strVersion = "4.7" '***** START WARNING - REMOVAL OR MODIFICATION OF THIS CODE WILL VIOLATE THE LICENSE AGREEMENT ****** Const strSalt = "5CB237B1D85" Const strCodeField = "L_code" Const intRelayType = 50 '***** END WARNING - REMOVAL OR MODIFICATION OF THIS CODE WILL VIOLATE THE LICENSE AGREEMENT ****** 'Set up the database table name prefix Const strDbTable = "tblML" 'Database Type Const strDatabaseType = "Access" 'Const strDatabaseType = "SQLServer" 'Create database connection 'Create a connection odject Set adoCon = Server.CreateObject("ADODB.Connection") 'If this is access set the access driver If strDatabaseType = "Access" Then '--------------------- Set the path and name of the database -------------------------------------------------------------------------------- 'Virtual path to database 'strDbPathAndName = Server.MapPath("database/mailing_list.mdb") 'This is the path of the database from this files location on the server 'Physical path to database strDbPathAndName = " E:\www\w\wholehealthconnectioncom\fpdb\mailing_list.mdb" 'Use this if you use the physical server path, eg:- C:\Inetpub\private\mailing_list.mdb 'PLEASE NOTE: - For extra security it is highly recommended you change the name of the database, mailing_list.mdb, to another name and then 'replace the wwForum.mdb found above with the name you changed the forum database to. '--------------------------------------------------------------------------------------------------------------------------------------------- '------------- If you are having problems with the script then try using a diffrent driver or DSN by editing the lines below -------------- 'Database connection info and driver (if this driver does not work then comment it out and use one of the alternative drivers) 'strCon = "DRIVER={Microsoft Access Driver (*.mdb)}; DBQ=" & strDbPathAndName 'Alternative drivers faster than the generic one above 'strCon = "Provider=Microsoft.Jet.OLEDB.3.51; Data Source=" & strDbPathAndName 'This one is if you convert the database to Access 97 strCon = "Provider=Microsoft.Jet.OLEDB.4.0; Data Source=" & strDbPathAndName 'This one is for Access 2000/2002 'If you wish to use DSN then comment out the driver above and uncomment the line below (DSN is slower than the above drivers) 'strCon = "DSN=DSN_NAME" 'Place the DSN where you see DSN_NAME '--------------------------------------------------------------------------------------------------------------------------------------------- 'The now() function is used in Access for dates strDatabaseDateFunction = "Now()" 'Set true and false strDBFalse = "false" strDBTrue = "true" 'Else set the MS SQL server stuff Else %><% '**************************************************************************************** '** Copyright Notice '** '** Web Wiz Mailing List '** http://www.webwizmailinglist.com '** '** Copyright ©2002-2006 Web Wiz. All Rights Reserved. '** '** THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS UNDER LICENSE FROM 'WEB WIZ'. '** '** IF YOU DO NOT AGREE TO THE LICENSE AGREEMENT THEN 'WEB WIZ' IS UNWILLING TO LICENSE '** THE SOFTWARE TO YOU, AND YOU SHOULD DESTROY ALL COPIES YOU HOLD OF 'WEB WIZ' SOFTWARE '** AND DERIVATIVE WORKS IMMEDIATELY. '** '** If you have not received a copy of the license with this work then a copy of the latest '** license contract can be found at:- '** '** http://www.webwizguide.com/license '** '** For more information about this software and for licensing information please contact '** 'Web Wiz' at the address and website below:- '** '** Web Wiz, Unit 10E, Dawkins Road Industrial Estate, Poole, Dorset, BH15 4JD, England '** http://www.webwizguide.com '** '** Removal or modification of this copyright notice will violate the license contract. '** '**************************************************************************************** Dim strSQLServerName 'Holds the name of the SQL Server Dim strSQLDBUserName 'Holds the user name (for SQL Server Authentication) Dim strSQLDBPassword 'Holds the password (for SQL Server Authentication) Dim strSQLDBName 'Holds name of a database on the server '------------- The Driver Below is if you are using SQL Server (Do Not Use Unless you know and have an SQL Server) --------------------------- 'Enter the details of your SQL server below strSQLServerName = "" 'Holds the name of the SQL Server (This is the name/location or IP address of the SQL Server) strSQLDBUserName = "" 'Holds the user name (for SQL Server Authentication) strSQLDBPassword = "" 'Holds the password (for SQL Server Authentication) strSQLDBName = "" 'Holds name of a database on the server 'Please note the forum has been optimised for the SQL OLE DB Driver using another driver 'or system DSN to connect to the SQL Server database will course errors in the forum and 'drastically reduce the performance of the forum! 'The SQLOLEDB driver offers the highest performance at this time for connecting to SQL Server databases from within ASP. 'MS SQL Server OLE Driver (If you change this string make sure you also change it in the msSQL_server_setup.asp file when creating the database) strCon = "Provider=SQLOLEDB;Server=" & strSQLServerName & ";User ID=" & strSQLDBUserName & ";Password=" & strSQLDBPassword & ";Database=" & strSQLDBName & ";Connection Timeout=90;" '--------------------------------------------------------------------------------------------------------------------------------------------- %><% 'The GetDate() function is used in SQL Server strDatabaseDateFunction = "GetDate()" 'Set true and false strDBFalse = 0 strDBTrue = 1 End If adoCon.connectionstring = strCon 'Set an active connection to the Connection object adoCon.Open 'Read in the mailing list configuration 'Intialise the ADO recordset object Set rsCommon = Server.CreateObject("ADODB.Recordset") 'Initialise the SQL variable with an SQL statement to get the configuration details from the database strSQL = "SELECT " & strDbTable & "Configuration.* From " & strDbTable & "Configuration;" 'Query the database rsCommon.Open strSQL, adoCon 'If there is config deatils in the recordset then read them in If NOT rsCommon.EOF Then 'Read in the configuration details from the recordset strWebsiteName = rsCommon("Website_name") strWebsiteAddress = rsCommon("Website_address") strWebsiteEmailAddress = rsCommon("Website_email_address") strTestEmailAddress = rsCommon("Test_email_address") strTitleImage = rsCommon("Title_image") strMailComponent = rsCommon("Mail_component") strMailServer = rsCommon("Mail_server") strMailServerUser = rsCommon("Mail_username") strMailServerPass = rsCommon("Mail_password") strWelcomeEmailSub = rsCommon("Welcome_email_subject") strWelcomeEmailHTML = rsCommon("Welcome_email_HTML") strWelcomeEmailText = rsCommon("Welcome_email_text") blnLCode = CBool(rsCommon("L_code")) blnActivate = CBool(rsCommon("Activate")) blnPlainTextOption = CBool(rsCommon("PlainText_Option")) blnEncryptPasswords = CBool(rsCommon("Encrypt_passwords")) blnJoinNotify = CBool(rsCommon("Join_notify")) blnRemoveNotify = CBool(rsCommon("Remove_notify")) strUploadComponent = rsCommon("Upload_component") strImageTypes = rsCommon("Upload_img_types") strFileUploadPath = rsCommon("Upload_path") strFileTypes = rsCommon("Upload_files_type") strPrivacyStatment = rsCommon("Privacy") strSignature = rsCommon("Signature") End If 'Reset server object rsCommon.Close blnAbout = blnLCode %><% '**************************************************************************************** '** Copyright Notice '** '** Web Wiz Mailing List '** http://www.webwizmailinglist.com '** '** Copyright ©2002-2006 Web Wiz. All Rights Reserved. '** '** THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS UNDER LICENSE FROM 'WEB WIZ'. '** '** IF YOU DO NOT AGREE TO THE LICENSE AGREEMENT THEN 'WEB WIZ' IS UNWILLING TO LICENSE '** THE SOFTWARE TO YOU, AND YOU SHOULD DESTROY ALL COPIES YOU HOLD OF 'WEB WIZ' SOFTWARE '** AND DERIVATIVE WORKS IMMEDIATELY. '** '** If you have not received a copy of the license with this work then a copy of the latest '** license contract can be found at:- '** '** http://www.webwizguide.com/license '** '** For more information about this software and for licensing information please contact '** 'Web Wiz' at the address and website below:- '** '** Web Wiz, Unit 10E, Dawkins Road Industrial Estate, Poole, Dorset, BH15 4JD, England '** http://www.webwizguide.com '** '** Removal or modification of this copyright notice will violate the license contract. '** '**************************************************************************************** '****************************************** '*** Unsafe character Strip **** '****************************************** 'Function to strip non alphanumeric characters email addresses Private Function characterStrip(ByVal strTextInput) 'Dimension variable Dim intLoopCounter 'Holds the loop counter 'Loop through the ASCII characters For intLoopCounter = 0 to 37 strTextInput = Replace(strTextInput, CHR(intLoopCounter), "", 1, -1, 0) Next 'Loop through the ASCII characters For intLoopCounter = 39 to 44 strTextInput = Replace(strTextInput, CHR(intLoopCounter), "", 1, -1, 0) Next 'Loop through the ASCII characters numeric characters to lower-case characters For intLoopCounter = 65 to 94 strTextInput = Replace(strTextInput, CHR(intLoopCounter), "", 1, -1, 0) Next 'Loop through the extended ASCII characters For intLoopCounter = 123 to 125 strTextInput = Replace(strTextInput, CHR(intLoopCounter), "", 1, -1, 0) Next 'Loop through the extended ASCII characters For intLoopCounter = 127 to 255 strTextInput = Replace(strTextInput, CHR(intLoopCounter), "", 1, -1, 0) Next 'Strip individul ASCII characters left out from above strTextInput = Replace(strTextInput, CHR(59), "", 1, -1, 0) strTextInput = Replace(strTextInput, CHR(60), "", 1, -1, 0) strTextInput = Replace(strTextInput, CHR(62), "", 1, -1, 0) strTextInput = Replace(strTextInput, CHR(96), "", 1, -1, 0) 'Return the string characterStrip = strTextInput End Function 'Function to strip non alphanumeric characters from user ID's Private Function IDcharacterStrip(ByVal strTextInput) 'Only allows 1 to 9, A to F, and Z 'Dimension variable Dim intLoopCounter 'Holds the loop counter 'Loop through the ASCII characters For intLoopCounter = 0 to 47 strTextInput = Replace(strTextInput, CHR(intLoopCounter), "", 1, -1, 0) Next 'Loop through the ASCII characters For intLoopCounter = 58 to 64 strTextInput = Replace(strTextInput, CHR(intLoopCounter), "", 1, -1, 0) Next 'Loop through the ASCII characters numeric characters to lower-case characters For intLoopCounter = 71 to 89 strTextInput = Replace(strTextInput, CHR(intLoopCounter), "", 1, -1, 0) Next 'Loop through the extended ASCII characters For intLoopCounter = 91 to 255 strTextInput = Replace(strTextInput, CHR(intLoopCounter), "", 1, -1, 0) Next 'Return the string IDcharacterStrip = strTextInput End Function '****************************************** '*** Random Hex Generator **** '****************************************** Private Function hexValue(ByVal intHexLength) Dim intLoopCounter Dim strHexValue 'Randomise the system timer Randomize Timer() 'Generate a hex value For intLoopCounter = 1 to intHexLength 'Genreate a radom decimal value form 0 to 15 intHexLength = CInt(Rnd * 1000) Mod 16 'Turn the number into a hex value Select Case intHexLength Case 1 strHexValue = "1" Case 2 strHexValue = "2" Case 3 strHexValue = "3" Case 4 strHexValue = "4" Case 5 strHexValue = "5" Case 6 strHexValue = "6" Case 7 strHexValue = "7" Case 8 strHexValue = "8" Case 9 strHexValue = "9" Case 10 strHexValue = "A" Case 11 strHexValue = "B" Case 12 strHexValue = "C" Case 13 strHexValue = "D" Case 14 strHexValue = "E" Case 15 strHexValue = "F" Case Else strHexValue = "Z" End Select 'Place the hex value into the return string hexValue = hexValue & strHexValue Next End Function '********************************************* '*** Strip all tags ***** '********************************************* 'Remove all tags for text only display Private Function removeAllTags(ByVal strInputEntry) 'Remove all HTML scripting tags etc. for plain text output strInputEntry = Replace(strInputEntry, "<", "<", 1, -1, 1) strInputEntry = Replace(strInputEntry, ">", ">", 1, -1, 1) strInputEntry = Replace(strInputEntry, "'", "’", 1, -1, 1) strInputEntry = Replace(strInputEntry, """", """, 1, -1, 1) 'Return removeAllTags = strInputEntry End Function '****************************************** '*** HTML Decoder **** '****************************************** 'Decode encoded strings Private Function decodeString(ByVal strInputEntry) 'Remove malisous charcters from links and images strInputEntry = Replace(strInputEntry, "=", "=", 1, -1, 0) strInputEntry = Replace(strInputEntry, "a", "a", 1, -1, 0) strInputEntry = Replace(strInputEntry, "b", "b", 1, -1, 0) strInputEntry = Replace(strInputEntry, "c", "c", 1, -1, 0) strInputEntry = Replace(strInputEntry, "d", "d", 1, -1, 0) strInputEntry = Replace(strInputEntry, "e", "e", 1, -1, 0) strInputEntry = Replace(strInputEntry, "f", "f", 1, -1, 0) strInputEntry = Replace(strInputEntry, "g", "g", 1, -1, 0) strInputEntry = Replace(strInputEntry, "h", "h", 1, -1, 0) strInputEntry = Replace(strInputEntry, "i", "i", 1, -1, 0) strInputEntry = Replace(strInputEntry, "j", "j", 1, -1, 0) strInputEntry = Replace(strInputEntry, "k", "k", 1, -1, 0) strInputEntry = Replace(strInputEntry, "l", "l", 1, -1, 0) strInputEntry = Replace(strInputEntry, "m", "m", 1, -1, 0) strInputEntry = Replace(strInputEntry, "n", "n", 1, -1, 0) strInputEntry = Replace(strInputEntry, "o", "o", 1, -1, 0) strInputEntry = Replace(strInputEntry, "p", "p", 1, -1, 0) strInputEntry = Replace(strInputEntry, "q", "q", 1, -1, 0) strInputEntry = Replace(strInputEntry, "r", "r", 1, -1, 0) strInputEntry = Replace(strInputEntry, "s", "s", 1, -1, 0) strInputEntry = Replace(strInputEntry, "t", "t", 1, -1, 0) strInputEntry = Replace(strInputEntry, "u", "u", 1, -1, 0) strInputEntry = Replace(strInputEntry, "v", "v", 1, -1, 0) strInputEntry = Replace(strInputEntry, "w", "w", 1, -1, 0) strInputEntry = Replace(strInputEntry, "x", "x", 1, -1, 0) strInputEntry = Replace(strInputEntry, "y", "y", 1, -1, 0) strInputEntry = Replace(strInputEntry, "z", "z", 1, -1, 0) strInputEntry = Replace(strInputEntry, "A", "A", 1, -1, 0) strInputEntry = Replace(strInputEntry, "B", "B", 1, -1, 0) strInputEntry = Replace(strInputEntry, "C", "C", 1, -1, 0) strInputEntry = Replace(strInputEntry, "D", "D", 1, -1, 0) strInputEntry = Replace(strInputEntry, "E", "E", 1, -1, 0) strInputEntry = Replace(strInputEntry, "F", "F", 1, -1, 0) strInputEntry = Replace(strInputEntry, "G", "G", 1, -1, 0) strInputEntry = Replace(strInputEntry, "H", "H", 1, -1, 0) strInputEntry = Replace(strInputEntry, "I", "I", 1, -1, 0) strInputEntry = Replace(strInputEntry, "J", "J", 1, -1, 0) strInputEntry = Replace(strInputEntry, "K", "K", 1, -1, 0) strInputEntry = Replace(strInputEntry, "L", "L", 1, -1, 0) strInputEntry = Replace(strInputEntry, "M", "M", 1, -1, 0) strInputEntry = Replace(strInputEntry, "N", "N", 1, -1, 0) strInputEntry = Replace(strInputEntry, "O", "O", 1, -1, 0) strInputEntry = Replace(strInputEntry, "P", "P", 1, -1, 0) strInputEntry = Replace(strInputEntry, "Q", "Q", 1, -1, 0) strInputEntry = Replace(strInputEntry, "R", "R", 1, -1, 0) strInputEntry = Replace(strInputEntry, "S", "S", 1, -1, 0) strInputEntry = Replace(strInputEntry, "T", "T", 1, -1, 0) strInputEntry = Replace(strInputEntry, "U", "U", 1, -1, 0) strInputEntry = Replace(strInputEntry, "V", "V", 1, -1, 0) strInputEntry = Replace(strInputEntry, "W", "W", 1, -1, 0) strInputEntry = Replace(strInputEntry, "X", "X", 1, -1, 0) strInputEntry = Replace(strInputEntry, "Y", "Y", 1, -1, 0) strInputEntry = Replace(strInputEntry, "Z", "Z", 1, -1, 0) strInputEntry = Replace(strInputEntry, "0", "0", 1, -1, 0) strInputEntry = Replace(strInputEntry, "1", "1", 1, -1, 0) strInputEntry = Replace(strInputEntry, "2", "2", 1, -1, 0) strInputEntry = Replace(strInputEntry, "3", "3", 1, -1, 0) strInputEntry = Replace(strInputEntry, "4", "4", 1, -1, 0) strInputEntry = Replace(strInputEntry, "5", "5", 1, -1, 0) strInputEntry = Replace(strInputEntry, "6", "6", 1, -1, 0) strInputEntry = Replace(strInputEntry, "7", "7", 1, -1, 0) strInputEntry = Replace(strInputEntry, "8", "8", 1, -1, 0) strInputEntry = Replace(strInputEntry, "9", "9", 1, -1, 0) 'Return decodeString = strInputEntry End Function %><% '**************************************************************************************** '** Copyright Notice '** '** Web Wiz Mailing List '** http://www.webwizmailinglist.com '** '** Copyright ©2002-2006 Web Wiz. All Rights Reserved. '** '** THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS UNDER LICENSE FROM 'WEB WIZ'. '** '** IF YOU DO NOT AGREE TO THE LICENSE AGREEMENT THEN 'WEB WIZ' IS UNWILLING TO LICENSE '** THE SOFTWARE TO YOU, AND YOU SHOULD DESTROY ALL COPIES YOU HOLD OF 'WEB WIZ' SOFTWARE '** AND DERIVATIVE WORKS IMMEDIATELY. '** '** If you have not received a copy of the license with this work then a copy of the latest '** license contract can be found at:- '** '** http://www.webwizguide.com/license '** '** For more information about this software and for licensing information please contact '** 'Web Wiz' at the address and website below:- '** '** Web Wiz, Unit 10E, Dawkins Road Industrial Estate, Poole, Dorset, BH15 4JD, England '** http://www.webwizguide.com '** '** Removal or modification of this copyright notice will violate the license contract. '** '**************************************************************************************** '*********************************** '**** Mailing List Language **** '*********************************** 'Global '--------------------------------------------------------------------------------- Const strTxtMailingList = "Mailing List" Const strTxtThen = "then" Const strTxtClickhere = "click here" Const strTxtReturnToLogin = "Return to login" Const strTxtHi = "Hi" Const strTxtGreetingsFrom = "Greetings from" Const strTxtAllFieldsAreRequired = "all fields are required" Const strTxtName = "Name" Const strTxtEmail = "Email" Const strTxtPassword = "Password" Const strTxtEmailAddress = "Email Address" Const strTxtHTML = "HTML" Const strTxtPlainText = "Plain Text" Const strTxtIfYouWouldLikeToMakeChagesToYourMailingListAccountOrUnsubscribe = "If you would like to make changes to your mailing list account, or unsubscribe" Const strTxtToUnsubscribeOrChangePref = "To unsubscribe or change your preferences goto the Mailing List Management Centre at the following address" Const strTxtCookiesEnabled = "Please ensure cookies are enabled on your web browser" Const strTxtNoMessageError = "Message Box \t\t- Enter a Message to Submit" Const strTxtErrorDisplayLine = "_______________________________________________________________" Const strTxtErrorDisplayLine1 = "The form has not been submitted because there are problem(s) with the form." Const strTxtErrorDisplayLine2 = "Please correct the problem(s) and re-submit the form." Const strTxtErrorDisplayLine3 = "The following field(s) need to be corrected: -" 'default.asp '--------------------------------------------------------------------------------- Const strTxtWelcomeTo = "Welcome to" Const strTxtAsASubscriberYouWillAccessEmailNewsletters = "As a subscriber, you will have full access to all of our Email Newsletters" Const strTxtYoullAlsoBeAbleTo = "You'll also be able to" Const strTxtManageMailingListSubscriptions = "Manage Mailing List Subscriptions" Const strTxtMakeChangesToYourAccount = "Make changes to your account" Const strTxtUnsubscribeFrom = "Unsubscribe from" Const strTxtViewSentNewsletters = "View Archived Newsletters" Const strTxtView = "View" Const strTxtExistingSubscribersPleaseLogin = "Existing Subscribers please login" Const strTxtSigningUpIsQuickEasyAndFREE = "Signing up is quick, easy and FREE" Const strTxtJustClickTheButtonBelow = "Just Click the button below" Const strTxtOpenNewAccount = "Open New Account" Const strTxtExistingSubscribersEnterYourLoginDetailsBelow = "Existing Subscribers enter your login details below" Const strTxtForgottenYourPassword = "Forgotten your password" Const strTxtAutoLogin = "Auto Login" Const strTxtYes = "Yes" Const strTxtNo = "No" Const strTxtLoginToMyAccount = "Login To My Account" Const strTxtPleaseConfirmTheEmailAddressAndPasswordYouHaveEnteredAndTryAgainOr = "Please confirm the email address and password you have entered and try again or " Const strTxtToSignupAsANewMember = "to sign up as a new member" Const strTxtMailingListLogin = "Mailing List Login" Const strTxtPassworEnterYourPassword = "Password \t- Enter your Password" 'privacy.asp '--------------------------------------------------------------------------------- Const strTxtPrivacyStatement = "Privacy Statement" Const strTxtIfYouWouldLikeToCreateEditOrCloseAMailingListAccountWith = "If you would like to Create, Edit, or Close a Mailing List account with" 'forgot_password.asp '--------------------------------------------------------------------------------- Const strTxtEmailAddressEnterYourValidEmailAddress = "Email Address\t- Enter your valid email address" Const strTxtForgottenPassword = "Forgotten Password" Const strTxtTheEmailAddressEnteredCouldNotBeFound = "The Email address entered could not be found" Const strTxtPleaseConfirmTheEmailAddressYouEnteredOrClick = "Please confirm the email address you entered or click" Const strTxtNewPasswordRequest = "New Password Request" Const strTxtANewPasswordHasBeenEmailedToYou = "A new Password has been emailed to you" Const strTxtPleaseCheckYourEmailInboxForAMessageWithTheSubjectLine = "Please check your email inbox for a message with the subject line" Const strTxtPleasEnterYourEmailAddressYouUseForTheMailingListToRequestPassword = "Please enter your email address you use for the mailing list to request a new password via email" Const strTxtWeReceivedYourRequestForANewPassswordForTheMailingListOn = "We received your request for a new password for the mailing list on" Const strTxtYourNewPasswordIs = "Your new password is" Const strTxtToLoginIntoYourMailingListAccountClickOnTheAddressBelow = "To login into your mailing list account click on the address below" 'sign_up.asp '--------------------------------------------------------------------------------- Const strTxtWeReceivedYourRequestToSubscribe = "We received your request to subscribe to one or more categories on the" Const strTxtToActivateYourSubscriptionClickTheAddressBelow = "To activate your subscription click the address below" Const strTxtIfYouDidNotSubscribe = "If you did not subscribe or this email is in error, then please just ignore it, you need do nothing more" Const strTxtThankYouForYourInterest = "Thank-you for your interest" Const strTxtNameEnterYourName = "Name \t\t- Enter your name" Const strTxtPasswordYourPasswordMustB4Characters = "Password \t- Your Password must be at least 4 characters" Const strTxtPasswordErrorPasswordsDoNotMatch = "Password Error\t- The passwords entered do not match" Const strTxtCreateAccount = "Create Account" Const strTxtYourSubscriptionRequestCouldNotBeProcessed = "Your subscription request could not be processed" Const strTxtEmailAdressNotValid = "The email address you entered is not valid! Please enter a valid email address" Const strTxtTheEmailAddressOrDomainEntered = "The email address or email domain you entered" Const strTxtIsNotPermittedPleaseEnterNew = "is not permitted. Please enter a different email address" Const strTxtTheEmailAddressYouEntered = "The email address you entered" Const strTxtIsAlreadySubscribedPlease = "is already subscribed. Please" Const strTxtToLogInWithThisAddressToEditAccount = "to log in with this address to view and edit your account" Const strTxtPleaseEnterAValidName = "Please enter a valid name" Const strTxtPleaseEnterAValidPassword = "Please enter a valid password" Const strTxtNewAccountDetails = "New Account Details" Const strTxtPleaseRegisterToActivateYourMailingListSubscription = "Please register to activate your mailing list subscription. You will periodically be notified of important " Const strTxtFeaturesAndNewsYouCanUnsubscribe = "features and news. Naturally, you can unsubscribe from the mailing list at any time" Const strTxtConfirmPassword = "Confirm Password" Const strTxtEmailDeliveryFormat = "Email Delivery Format" Const strTxtCategories = "Categories" Const strTxtPleaseSelectFromTheListBelowWhich = "Please select from the list below which" Const strTxtCatsYouAreInterestedIn = "mailing list categories that you are interested in. Select as many categories as you wish. You can modify your profile at any time to change your subscriptions" Const strTxtCreateMyAccount = "Create My Account" 'activate_confirm.asp '--------------------------------------------------------------------------------- Const strTxtConfirmSubscription = "Confirm Subscription" Const strTxtIMPORTANTConfirmYourSubscription = "IMPORTANT: Confirm Your Subscription" Const strTxtThankYouForYourInterestIn = "Thank-you for your interest in" Const strTxtThereIsOneMoreStepToComplete = "mailing list. There is one more step before your subscription is complete" Const strTxtConformYourSubscriptionToMailingList = "Confirm your subscription to mailing list" Const strTxtSimplyClickTheLinkInsideThisEmailToAct = "Simply click the link inside this email to activate your subscription" Const strTxtWeRequireThisStepToProtectOurMembers = "We require this email step to protect our members" Const strTxtYouWillNotBeSubscribedTillThisStepIsComplete = "You will not be subscribed until you complete this step" 'activate.asp '--------------------------------------------------------------------------------- Const strTxtSubscriptionActivated = "Subscription Activated" Const strTxtAdmin = "Admin" Const strTxtThisEmailIsToNotifyYouThatTheFollowingPersonHasSubscribedToThe = "This email is to notify you that the following person has subscribed to the" Const strTxtActivateSubscription = "Activate Subscription" Const strTxtThankYouForJoining = "Thank-you for joining" Const strTxtYourSubscriptionTo = "Your subscription to" Const strTxtMailingListIsNow = "mailing list is now" Const strTxtReActivated = "re-activated" Const strTxtActive = "active" Const strTxtThankYouForYourInterestInJoining = "Thank-you for your interest in joining" Const strTxtAnErrorHasOccurred = "An Error has occurred" Const strTxtThereWhereProblemsActivatingYourAccount = "There was a problem activating your account.
Please contact the" Const strTxtAdministratorAt = "administrator at" Const strTxtToHaveYourAccountActivated = "to have your account activated" 'management_centre.asp '--------------------------------------------------------------------------------- Const strTxtReConfirmYourSubscriptionTo = "Re-Confirm Your Subscription To" Const strTxtYouHaveSucessfullyChangedYour = "You have successfully changed your" Const strTxtPreferences = "preferences" Const strTxtAsYourEmailAddressHasCHangedYouWillNeedToReactivateYourAccount = "As your email address has been changed you will need to re-activate your subscription by clicking the address below" Const strTxtMailingListPreferencesUpdated = "Mailing List Preferences Updated" Const strTxtIfYouWouldLikeToChangeYourPreferencesAgain = "If you would like to change your preferences again, you may do so through the Mailing List Management Centre at the following address" Const strTxtNew = "New" Const strTxtCurrentPasswordEnterCurrentPassword = "Current Password \t- Enter your Current Password" Const strTxtPasswordError = "Password Error\t- The passwords entered do not match" Const strTxtManagementCentre = "Management Centre" Const strTxtTheCurrentPasswordIsIncorrect = "The password entered as the current password was incorrect" Const strTxtYourAccountDetails = "Your Account Details" Const strTxtIfYouWouldLikeToChangeYour = "If you would like to change your" Const strTxtDetailsUseTheFormBelow = "details please use the form below" Const strTxtYourSubscriptionIsPresentlyConfirmed = "Your subscription is presently confirmed" Const strTxtYourSubscriptionIsPresentlyNOTConfirmed = "Your subscription is presently not confirmed" Const strTxtReSendConfirmationEmail = "Re-send confirmation email" Const strTxtYourPassword = "Your Password" Const strTxtIfYouWouldLikeToChnageYourPassword = "If you would like to change your password fill in the form below" Const strTxtCurrentPassword = "Current Password" Const strTxtNewPassword = "New Password" Const strTxtYouSubscribedToTheChecked = "You have subscribed to the checked" Const strTxtCategoriesBelowToChangeCheckBoxes = "categories below. To subscribe to additional categories, select the box next to the category title. To unsubscribe deselect the box" Const strTxtUpdateMyAccount = "Update My Account" Const strTxtAreYouSureYouWishToUnsubscribeFrom = "Are you sure you wish to unsubscribe from" Const strTxtIfYouWouldLikeToUnsubscribeFromThe = "If you would like to unsubscribe from the" Const strTxtAndHaveYourAccountDeleted = "and have your account permanently deleted, then click on the button below" Const strTxtOnceYourUnsubscribeYouWillGetEmail = "Once you unsubscribe you will receive one last email from" Const strTxtToConfirmYourSubscriptionToThe = "to confirm that your subscription to the" Const strTxtIsClosed = "is closed" Const strTxtDeleteMyAccount = "Delete My Account" Const strTxtYourSubscriptionUpdateRequestCouldNotBeProcessed = "Your subscription update request could not be processed" 'delete_account.asp '--------------------------------------------------------------------------------- Const strTxtThisIsToConfirmThatYouHaveUnsubscribed = "This is to confirm that you have un subscribed form the" Const strTxtUnsubscribeConfirmation = "Unsubscribe Confirmation" Const strTxtThisIsToNotifyThatTheFollowingHasUnsubscribed = "This email is to notify you that the following person has un subscribed from the" Const strTxtYouHaveNowUnsubscribedFromAllCategories = "You have now un subscribed from all categories in the" Const strTxtAConfirmationEmailWillBEmailedToYou = "A confirmation email of this will be emailed to yourself" 'newsletters.asp '--------------------------------------------------------------------------------- Const strTxtSentNewsletters = "Archived Newsletters" Const strTxtThereAreNoSavedNewsletters = "There are no Archived Newsletters to display" Const strTxtPleaseCheckBackLater = "Please check back later" Const strTxtFormat = "Format" Const strTxtDateSent = "Date Sent" Const strTxtAt = "at" Const strTxtReturnToLoginSignup = "Return to login/sign-up" 'view_newsletter.asp '--------------------------------------------------------------------------------- Const strTxtNewsletter = "Newsletter" Const strTxtDetails = "Details" Const strTxtSubject = "Subject" Const strTxtNote = "Note" Const strTxtSelectAnotherNewsletterToView = "Select Another Newsletter To View" 'resend_activation_email.asp '--------------------------------------------------------------------------------- Const strTxtMailingListReSentConformYourSub = "mailing list has been re-sent. Please follow the last step to confirm your subscription" 'management_centre_update.asp '--------------------------------------------------------------------------------- Const strTxtIMPORTANTREConfirmYourSubscription = "IMPORTANT: Re-Confirm Your Subscription" Const strTxtReConfirmYourSubscriptionToMailingList = "Re-Confirm your subscription to mailing list" Const strTxtTheEmailAddressYouUseFor = "The email address you use for" Const strTxtMailingListHasChangedYouReqToConfirm = "mailing list has been changed. You are required to confirm the email address you have entered" Const strTxtYourAccountSuspendedUntilYouCompleteStep = "Your account will be suspended until you complete this step" Const strTxtYourUpdatedAccountDetails = "Your Updated Account Details" Const strTxtSubscriptionConfirmed = "Subscription Confirmed" Const strTxtMailingListCategoriesSubscribedTo = "Mailing List Categories Subscribed to" Const strTxtYouHaveSubscribedToThe = "You have subscribed to the" Const strTxtMailingListCategoriesBelow = "mailing list categories below" Const strTxtThereAreNoCategoriesToDisplay = "There are no categories to display" %> <% '**************************************************************************************** '** Copyright Notice '** '** Web Wiz Mailing List '** http://www.webwizmailinglist.com '** '** Copyright ©2002-2006 Web Wiz. All Rights Reserved. '** '** THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS UNDER LICENSE FROM 'WEB WIZ'. '** '** IF YOU DO NOT AGREE TO THE LICENSE AGREEMENT THEN 'WEB WIZ' IS UNWILLING TO LICENSE '** THE SOFTWARE TO YOU, AND YOU SHOULD DESTROY ALL COPIES YOU HOLD OF 'WEB WIZ' SOFTWARE '** AND DERIVATIVE WORKS IMMEDIATELY. '** '** If you have not received a copy of the license with this work then a copy of the latest '** license contract can be found at:- '** '** http://www.webwizguide.com/license '** '** For more information about this software and for licensing information please contact '** 'Web Wiz' at the address and website below:- '** '** Web Wiz, Unit 10E, Dawkins Road Industrial Estate, Poole, Dorset, BH15 4JD, England '** http://www.webwizguide.com '** '** Removal or modification of this copyright notice will violate the license contract. '** '**************************************************************************************** '****************************************** '*** Unsafe character Strip **** '****************************************** 'Function to strip non alphanumeric characters email addresses Private Function characterStrip(ByVal strTextInput) 'Dimension variable Dim intLoopCounter 'Holds the loop counter 'Loop through the ASCII characters For intLoopCounter = 0 to 37 strTextInput = Replace(strTextInput, CHR(intLoopCounter), "", 1, -1, 0) Next 'Loop through the ASCII characters For intLoopCounter = 39 to 44 strTextInput = Replace(strTextInput, CHR(intLoopCounter), "", 1, -1, 0) Next 'Loop through the ASCII characters numeric characters to lower-case characters For intLoopCounter = 65 to 94 strTextInput = Replace(strTextInput, CHR(intLoopCounter), "", 1, -1, 0) Next 'Loop through the extended ASCII characters For intLoopCounter = 123 to 125 strTextInput = Replace(strTextInput, CHR(intLoopCounter), "", 1, -1, 0) Next 'Loop through the extended ASCII characters For intLoopCounter = 127 to 255 strTextInput = Replace(strTextInput, CHR(intLoopCounter), "", 1, -1, 0) Next 'Strip individul ASCII characters left out from above strTextInput = Replace(strTextInput, CHR(59), "", 1, -1, 0) strTextInput = Replace(strTextInput, CHR(60), "", 1, -1, 0) strTextInput = Replace(strTextInput, CHR(62), "", 1, -1, 0) strTextInput = Replace(strTextInput, CHR(96), "", 1, -1, 0) 'Return the string characterStrip = strTextInput End Function 'Function to strip non alphanumeric characters from user ID's Private Function IDcharacterStrip(ByVal strTextInput) 'Only allows 1 to 9, A to F, and Z 'Dimension variable Dim intLoopCounter 'Holds the loop counter 'Loop through the ASCII characters For intLoopCounter = 0 to 47 strTextInput = Replace(strTextInput, CHR(intLoopCounter), "", 1, -1, 0) Next 'Loop through the ASCII characters For intLoopCounter = 58 to 64 strTextInput = Replace(strTextInput, CHR(intLoopCounter), "", 1, -1, 0) Next 'Loop through the ASCII characters numeric characters to lower-case characters For intLoopCounter = 71 to 89 strTextInput = Replace(strTextInput, CHR(intLoopCounter), "", 1, -1, 0) Next 'Loop through the extended ASCII characters For intLoopCounter = 91 to 255 strTextInput = Replace(strTextInput, CHR(intLoopCounter), "", 1, -1, 0) Next 'Return the string IDcharacterStrip = strTextInput End Function '****************************************** '*** Random Hex Generator **** '****************************************** Private Function hexValue(ByVal intHexLength) Dim intLoopCounter Dim strHexValue 'Randomise the system timer Randomize Timer() 'Generate a hex value For intLoopCounter = 1 to intHexLength 'Genreate a radom decimal value form 0 to 15 intHexLength = CInt(Rnd * 1000) Mod 16 'Turn the number into a hex value Select Case intHexLength Case 1 strHexValue = "1" Case 2 strHexValue = "2" Case 3 strHexValue = "3" Case 4 strHexValue = "4" Case 5 strHexValue = "5" Case 6 strHexValue = "6" Case 7 strHexValue = "7" Case 8 strHexValue = "8" Case 9 strHexValue = "9" Case 10 strHexValue = "A" Case 11 strHexValue = "B" Case 12 strHexValue = "C" Case 13 strHexValue = "D" Case 14 strHexValue = "E" Case 15 strHexValue = "F" Case Else strHexValue = "Z" End Select 'Place the hex value into the return string hexValue = hexValue & strHexValue Next End Function '********************************************* '*** Strip all tags ***** '********************************************* 'Remove all tags for text only display Private Function removeAllTags(ByVal strInputEntry) 'Remove all HTML scripting tags etc. for plain text output strInputEntry = Replace(strInputEntry, "<", "<", 1, -1, 1) strInputEntry = Replace(strInputEntry, ">", ">", 1, -1, 1) strInputEntry = Replace(strInputEntry, "'", "’", 1, -1, 1) strInputEntry = Replace(strInputEntry, """", """, 1, -1, 1) 'Return removeAllTags = strInputEntry End Function '****************************************** '*** HTML Decoder **** '****************************************** 'Decode encoded strings Private Function decodeString(ByVal strInputEntry) 'Remove malisous charcters from links and images strInputEntry = Replace(strInputEntry, "=", "=", 1, -1, 0) strInputEntry = Replace(strInputEntry, "a", "a", 1, -1, 0) strInputEntry = Replace(strInputEntry, "b", "b", 1, -1, 0) strInputEntry = Replace(strInputEntry, "c", "c", 1, -1, 0) strInputEntry = Replace(strInputEntry, "d", "d", 1, -1, 0) strInputEntry = Replace(strInputEntry, "e", "e", 1, -1, 0) strInputEntry = Replace(strInputEntry, "f", "f", 1, -1, 0) strInputEntry = Replace(strInputEntry, "g", "g", 1, -1, 0) strInputEntry = Replace(strInputEntry, "h", "h", 1, -1, 0) strInputEntry = Replace(strInputEntry, "i", "i", 1, -1, 0) strInputEntry = Replace(strInputEntry, "j", "j", 1, -1, 0) strInputEntry = Replace(strInputEntry, "k", "k", 1, -1, 0) strInputEntry = Replace(strInputEntry, "l", "l", 1, -1, 0) strInputEntry = Replace(strInputEntry, "m", "m", 1, -1, 0) strInputEntry = Replace(strInputEntry, "n", "n", 1, -1, 0) strInputEntry = Replace(strInputEntry, "o", "o", 1, -1, 0) strInputEntry = Replace(strInputEntry, "p", "p", 1, -1, 0) strInputEntry = Replace(strInputEntry, "q", "q", 1, -1, 0) strInputEntry = Replace(strInputEntry, "r", "r", 1, -1, 0) strInputEntry = Replace(strInputEntry, "s", "s", 1, -1, 0) strInputEntry = Replace(strInputEntry, "t", "t", 1, -1, 0) strInputEntry = Replace(strInputEntry, "u", "u", 1, -1, 0) strInputEntry = Replace(strInputEntry, "v", "v", 1, -1, 0) strInputEntry = Replace(strInputEntry, "w", "w", 1, -1, 0) strInputEntry = Replace(strInputEntry, "x", "x", 1, -1, 0) strInputEntry = Replace(strInputEntry, "y", "y", 1, -1, 0) strInputEntry = Replace(strInputEntry, "z", "z", 1, -1, 0) strInputEntry = Replace(strInputEntry, "A", "A", 1, -1, 0) strInputEntry = Replace(strInputEntry, "B", "B", 1, -1, 0) strInputEntry = Replace(strInputEntry, "C", "C", 1, -1, 0) strInputEntry = Replace(strInputEntry, "D", "D", 1, -1, 0) strInputEntry = Replace(strInputEntry, "E", "E", 1, -1, 0) strInputEntry = Replace(strInputEntry, "F", "F", 1, -1, 0) strInputEntry = Replace(strInputEntry, "G", "G", 1, -1, 0) strInputEntry = Replace(strInputEntry, "H", "H", 1, -1, 0) strInputEntry = Replace(strInputEntry, "I", "I", 1, -1, 0) strInputEntry = Replace(strInputEntry, "J", "J", 1, -1, 0) strInputEntry = Replace(strInputEntry, "K", "K", 1, -1, 0) strInputEntry = Replace(strInputEntry, "L", "L", 1, -1, 0) strInputEntry = Replace(strInputEntry, "M", "M", 1, -1, 0) strInputEntry = Replace(strInputEntry, "N", "N", 1, -1, 0) strInputEntry = Replace(strInputEntry, "O", "O", 1, -1, 0) strInputEntry = Replace(strInputEntry, "P", "P", 1, -1, 0) strInputEntry = Replace(strInputEntry, "Q", "Q", 1, -1, 0) strInputEntry = Replace(strInputEntry, "R", "R", 1, -1, 0) strInputEntry = Replace(strInputEntry, "S", "S", 1, -1, 0) strInputEntry = Replace(strInputEntry, "T", "T", 1, -1, 0) strInputEntry = Replace(strInputEntry, "U", "U", 1, -1, 0) strInputEntry = Replace(strInputEntry, "V", "V", 1, -1, 0) strInputEntry = Replace(strInputEntry, "W", "W", 1, -1, 0) strInputEntry = Replace(strInputEntry, "X", "X", 1, -1, 0) strInputEntry = Replace(strInputEntry, "Y", "Y", 1, -1, 0) strInputEntry = Replace(strInputEntry, "Z", "Z", 1, -1, 0) strInputEntry = Replace(strInputEntry, "0", "0", 1, -1, 0) strInputEntry = Replace(strInputEntry, "1", "1", 1, -1, 0) strInputEntry = Replace(strInputEntry, "2", "2", 1, -1, 0) strInputEntry = Replace(strInputEntry, "3", "3", 1, -1, 0) strInputEntry = Replace(strInputEntry, "4", "4", 1, -1, 0) strInputEntry = Replace(strInputEntry, "5", "5", 1, -1, 0) strInputEntry = Replace(strInputEntry, "6", "6", 1, -1, 0) strInputEntry = Replace(strInputEntry, "7", "7", 1, -1, 0) strInputEntry = Replace(strInputEntry, "8", "8", 1, -1, 0) strInputEntry = Replace(strInputEntry, "9", "9", 1, -1, 0) 'Return decodeString = strInputEntry End Function %> <% Function getSalt(intLen) ' Function takes a given length x and generates a random hex value of x digits. ' Salt can be used to help protect passwords. When a password is first stored in a ' database generate a salt value also. Concatenate the salt value with the password, ' and then encrypt it using the HashEncode function below. Store both the salt value, ' and the encrypted value in the database. When a password needs to be verified, take ' the password concatenate the salt from the database. Encode it using the HashEncode ' function below. If the result matches the the encrypted password stored in the ' database, then it is a match. If not then the password is invalid. ' ' ' Note: Passwords become case sensitive when using this encryption. ' For more information on Password HASH Encoding, and SALT visit: http://local.15seconds.com/issue/000217.htm ' ' Call this function if you wish to generate a random hex value of any given length ' ' Written By: Mark G. Jager ' Written Date: 8/10/2000 ' ' Free to distribute as long as code is not modified, and header is kept intact Dim strSalt Dim intIndex, intRand If Not IsNumeric(intLen) Then getSalt = "00000000" exit function ElseIf CInt(intLen) <> CDbl(intLen) Or CInt(intLen) < 1 Then getSalt = "00000000" exit function End If Randomize For intIndex = 1 to CInt(intLen) intRand = CInt(Rnd * 1000) Mod 16 strSalt = strSalt & getDecHex(intRand) Next getSalt = strSalt End Function Function HashEncode(strSecret) ' Function takes an ASCII string less than 2^61 characters long and ' one way hash encrypts it using 160 bit encryption into a 40 digit hex value. ' The encoded hex value cannot be decoded to the original string value. ' ' This is the only function that you need to call for encryption. ' ' Written By: Mark G. Jager ' Written Date: 8/10/2000 ' ' Free to distribute as long as code is not modified, and header is kept intact ' ' The author makes no warranties as to the validity, and/or authenticity of this code. ' You may use any code found herein at your own risk. ' This code was written to follow as closely as possible the standards found in ' Federal Information Processing Standards Publication (FIPS PUB 180-1) ' http://csrc.nist.gov/fips/fip180-1.txt -- Secure Hash Standard SHA-1 ' ' This code is for private use only, and the security and/or encryption of the resulting ' hexadecimal value is not warrented or gaurenteed in any way. ' Dim strEncode, strH(4) Dim intPos If len(strSecret) = 0 or len(strSecret) >= 2^61 then HashEncode = "0000000000000000000000000000000000000000" exit function end if 'Initial Hex words are used for encoding Digest. 'These can be any valid 8-digit hex value (0 to F) strH(0) = "FB0C14C2" strH(1) = "9F00AB2E" strH(2) = "991FFA67" strH(3) = "76FA2C3F" strH(4) = "ADE426FA" For intPos = 1 to len(strSecret) step 56 strEncode = Mid(strSecret, intPos, 56) 'get 56 character chunks strEncode = WordToBinary(strEncode) 'convert to binary strEncode = PadBinary(strEncode) 'make it 512 bites strEncode = BlockToHex(strEncode) 'convert to hex value 'Encode the hex value using the previous runs digest 'If it is the first run then use the initial values above strEncode = DigestHex(strEncode, strH(0), strH(1), strH(2), strH(3), strH(4)) 'Combine the old digest with the new digest strH(0) = HexAdd(left(strEncode, 8), strH(0)) strH(1) = HexAdd(mid(strEncode, 9, 8), strH(1)) strH(2) = HexAdd(mid(strEncode, 17, 8), strH(2)) strH(3) = HexAdd(mid(strEncode, 25, 8), strH(3)) strH(4) = HexAdd(right(strEncode, 8), strH(4)) Next 'This is the final Hex Digest HashEncode = strH(0) & strH(1) & strH(2) & strH(3) & strH(4) End Function Function HexToBinary(btHex) ' Function Converts a single hex value into it's binary equivalent ' ' Written By: Mark Jager ' Written Date: 8/10/2000 ' ' Free to distribute as long as code is not modified, and header is kept intact ' Select Case btHex Case "0" HexToBinary = "0000" Case "1" HexToBinary = "0001" Case "2" HexToBinary = "0010" Case "3" HexToBinary = "0011" Case "4" HexToBinary = "0100" Case "5" HexToBinary = "0101" Case "6" HexToBinary = "0110" Case "7" HexToBinary = "0111" Case "8" HexToBinary = "1000" Case "9" HexToBinary = "1001" Case "A" HexToBinary = "1010" Case "B" HexToBinary = "1011" Case "C" HexToBinary = "1100" Case "D" HexToBinary = "1101" Case "E" HexToBinary = "1110" Case "F" HexToBinary = "1111" Case Else HexToBinary = "2222" End Select End Function Function BinaryToHex(strBinary) ' Function Converts a 4 bit binary value into it's hex equivalent ' ' Written By: Mark Jager ' Written Date: 8/10/2000 ' ' Free to distribute as long as code is not modified, and header is kept intact ' Select Case strBinary Case "0000" BinaryToHex = "0" Case "0001" BinaryToHex = "1" Case "0010" BinaryToHex = "2" Case "0011" BinaryToHex = "3" Case "0100" BinaryToHex = "4" Case "0101" BinaryToHex = "5" Case "0110" BinaryToHex = "6" Case "0111" BinaryToHex = "7" Case "1000" BinaryToHex = "8" Case "1001" BinaryToHex = "9" Case "1010" BinaryToHex = "A" Case "1011" BinaryToHex = "B" Case "1100" BinaryToHex = "C" Case "1101" BinaryToHex = "D" Case "1110" BinaryToHex = "E" Case "1111" BinaryToHex = "F" Case Else BinaryToHex = "Z" End Select End Function Function WordToBinary(strWord) ' Function Converts a 8 digit hex value into it's 32 bit binary equivalent ' ' Written By: Mark Jager ' Written Date: 8/10/2000 ' ' Free to distribute as long as code is not modified, and header kept intact ' Dim strTemp, strBinary Dim intPos For intPos = 1 To Len(strWord) strTemp = Mid(strWord, cint(intPos), 1) strBinary = strBinary & IntToBinary(Asc(strTemp)) Next WordToBinary = strBinary End Function Function HexToInt(strHex) ' Function Converts a hex word to its base 10(decimal) equivalent ' ' Written By: Mark Jager ' Written Date: 8/10/2000 ' ' Free to distribute as long as code is not modified, and header is kept intact ' Dim intNew, intPos, intLen intNew = 0 intLen = CDbl(len(strHex)) - 1 For intPos = CDbl(intLen) to 0 step -1 Select Case Mid(strHex, CDbl(intPos) + 1, 1) Case "0" intNew = CDbl(intNew) + (0 * 16^CDbl(intLen - intPos)) Case "1" intNew = CDbl(intNew) + (1 * 16^CDbl(intLen - intPos)) Case "2" intNew = CDbl(intNew) + (2 * 16^CDbl(intLen - intPos)) Case "3" intNew = CDbl(intNew) + (3 * 16^CDbl(intLen - intPos)) Case "4" intNew = CDbl(intNew) + (4 * 16^CDbl(intLen - intPos)) Case "5" intNew = CDbl(intNew) + (5 * 16^CDbl(intLen - intPos)) Case "6" intNew = CDbl(intNew) + (6 * 16^CDbl(intLen - intPos)) Case "7" intNew = CDbl(intNew) + (7 * 16^CDbl(intLen - intPos)) Case "8" intNew = CDbl(intNew) + (8 * 16^CDbl(intLen - intPos)) Case "9" intNew = CDbl(intNew) + (9 * 16^CDbl(intLen - intPos)) Case "A" intNew = CDbl(intNew) + (10 * 16^CDbl(intLen - intPos)) Case "B" intNew = CDbl(intNew) + (11 * 16^CDbl(intLen - intPos)) Case "C" intNew = CDbl(intNew) + (12 * 16^CDbl(intLen - intPos)) Case "D" intNew = CDbl(intNew) + (13 * 16^CDbl(intLen - intPos)) Case "E" intNew = CDbl(intNew) + (14 * 16^CDbl(intLen - intPos)) Case "F" intNew = CDbl(intNew) + (15 * 16^CDbl(intLen - intPos)) End Select Next HexToInt = CDbl(intNew) End Function Function IntToBinary(intNum) ' Function Converts an integer number to it's binary equivalent ' ' Written By: Mark Jager ' Written Date: 8/10/2000 ' ' Free to distribute as long as code is not modified, and header is kept intact ' Dim strBinary, strTemp Dim intNew, intTemp Dim dblNew intNew = intNum Do While intNew > 1 dblNew = CDbl(intNew) / 2 intNew = Round(CDbl(dblNew) - 0.1, 0) If CDbl(dblNew) = CDbl(intNew) Then strBinary = "0" & strBinary Else strBinary = "1" & strBinary End If Loop strBinary = intNew & strBinary intTemp = Len(strBinary) mod 8 For intNew = intTemp To 7 strBinary = "0" & strBinary Next IntToBinary = strBinary End Function Function PadBinary(strBinary) ' Function adds 0's to a binary string until it reaches 448 bits. ' The lenghth of the original string is incoded into the last 16 bits. ' The end result is a binary string 512 bits long ' ' Written By: Mark Jager ' Written Date: 8/10/2000 ' ' Free to distribute as long as code is not modified, and header is kept intact ' Dim intPos, intLen Dim strTemp intLen = Len(strBinary) strBinary = strBinary & "1" For intPos = Len(strBinary) To 447 strBinary = strBinary & "0" Next strTemp = IntToBinary(intLen) For intPos = Len(strTemp) To 63 strTemp = "0" & strTemp Next strBinary = strBinary & strTemp PadBinary = strBinary End Function Function BlockToHex(strBinary) ' Function Converts a 32 bit binary string into it's 8 digit hex equivalent ' ' Written By: Mark Jager ' Written Date: 8/10/2000 ' ' Free to distribute as long as code is not modified, and header is kept intact ' Dim intPos Dim strHex For intPos = 1 To Len(strBinary) Step 4 strHex = strHex & BinaryToHex(Mid(strBinary, intPos, 4)) Next BlockToHex = strHex End Function Function DigestHex(strHex, strH0, strH1, strH2, strH3, strH4) ' Main encoding function. Takes a 128 digit/512 bit hex value and one way encrypts it into ' a 40 digit/160 bit hex value. ' ' Written By: Mark Jager ' Written Date: 8/10/2000 ' ' Free to distribute as long as code is not modified, and header is kept intact ' Dim strWords(79), adoConst(4), strTemp, strTemp1, strTemp2, strTemp3, strTemp4 Dim intPos Dim strH(4), strA(4), strK(3) 'Constant hex words are used for encryption, these can be any valid 8 digit hex value strK(0) = "5A827999" strK(1) = "6ED9EBA1" strK(2) = "8F1BBCDC" strK(3) = "CA62C1D6" 'Hex words are used in the encryption process, these can be any valid 8 digit hex value strH(0) = strH0 strH(1) = strH1 strH(2) = strH2 strH(3) = strH3 strH(4) = strH4 'divide the Hex block into 16 hex words For intPos = 0 To (len(strHex) / 8) - 1 strWords(cint(intPos)) = Mid(strHex, (cint(intPos)*8) + 1, 8) Next 'encode the Hex words using the constants above 'innitialize 80 hex word positions For intPos = 16 To 79 strTemp = strWords(cint(intPos) - 3) strTemp1 = HexBlockToBinary(strTemp) strTemp = strWords(cint(intPos) - 8) strTemp2 = HexBlockToBinary(strTemp) strTemp = strWords(cint(intPos) - 14) strTemp3 = HexBlockToBinary(strTemp) strTemp = strWords(cint(intPos) - 16) strTemp4 = HexBlockToBinary(strTemp) strTemp = BinaryXOR(strTemp1, strTemp2) strTemp = BinaryXOR(strTemp, strTemp3) strTemp = BinaryXOR(strTemp, strTemp4) strWords(cint(intPos)) = BlockToHex(BinaryShift(strTemp, 1)) Next 'initialize the changing word variables with the initial word variables strA(0) = strH(0) strA(1) = strH(1) strA(2) = strH(2) strA(3) = strH(3) strA(4) = strH(4) 'Main encryption loop on all 80 hex word positions For intPos = 0 To 79 strTemp = BinaryShift(HexBlockToBinary(strA(0)), 5) strTemp1 = HexBlockToBinary(strA(3)) strTemp2 = HexBlockToBinary(strWords(cint(intPos))) Select Case intPos Case 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19 strTemp3 = HexBlockToBinary(strK(0)) strTemp4 = BinaryOR(BinaryAND(HexBlockToBinary(strA(1)), _ HexBlockToBinary(strA(2))), BinaryAND(BinaryNOT(HexBlockToBinary(strA(1))), _ HexBlockToBinary(strA(3)))) Case 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39 strTemp3 = HexBlockToBinary(strK(1)) strTemp4 = BinaryXOR(BinaryXOR(HexBlockToBinary(strA(1)), _ HexBlockToBinary(strA(2))), HexBlockToBinary(strA(3))) Case 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59 strTemp3 = HexBlockToBinary(strK(2)) strTemp4 = BinaryOR(BinaryOR(BinaryAND(HexBlockToBinary(strA(1)), _ HexBlockToBinary(strA(2))), BinaryAND(HexBlockToBinary(strA(1)), _ HexBlockToBinary(strA(3)))), BinaryAND(HexBlockToBinary(strA(2)), _ HexBlockToBinary(strA(3)))) Case 60, 61, 62, 63, 64, 65, 66, 67, 68, 69, 70, 71, 72, 73, 74, 75, 76, 77, 78, 79 strTemp3 = HexBlockToBinary(strK(3)) strTemp4 = BinaryXOR(BinaryXOR(HexBlockToBinary(strA(1)), _ HexBlockToBinary(strA(2))), HexBlockToBinary(strA(3))) End Select strTemp = BlockToHex(strTemp) strTemp1 = BlockToHex(strTemp1) strTemp2 = BlockToHex(strTemp2) strTemp3 = BlockToHex(strTemp3) strTemp4 = BlockToHex(strTemp4) strTemp = HexAdd(strTemp, strTemp1) strTemp = HexAdd(strTemp, strTemp2) strTemp = HexAdd(strTemp, strTemp3) strTemp = HexAdd(strTemp, strTemp4) strA(4) = strA(3) strA(3) = strA(2) strA(2) = BlockToHex(BinaryShift(HexBlockToBinary(strA(1)), 30)) strA(1) = strA(0) strA(0) = strTemp Next 'Concatenate the final Hex Digest DigestHex = strA(0) & strA(1) & strA(2) & strA(3) & strA(4) End Function Function HexAdd(strHex1, strHex2) ' Function adds to 8 digit/32 bit hex values together Mod 2^32 ' ' Written By: Mark Jager ' Written Date: 8/10/2000 ' ' Free to distribute as long as code is not modified, and header is kept intact ' Dim intCalc Dim strNew intCalc = 0 intCalc = CDbl(CDbl(HexToInt(strHex1)) + CDbl(HexToInt(strHex2))) Do While CDbl(intCalc) > 2^32 intCalc = CDbl(intCalc) - 2^32 Loop strNew = IntToBinary(CDbl(intCalc)) Do While Len(strNew) < 32 strNew = "0" & strNew Loop strNew = BlockToHex(strNew) if InStr(strNew, "00") = 1 and len(strNew) = 10 then strNew = right(strNew, 8) end if HexAdd = strNew End Function Function getHexDec(strHex) ' Function Converts a single hex value into it's decimal equivalent ' ' Written By: Mark Jager ' Written Date: 8/10/2000 ' ' Free to distribute as long as code is not modified, and header is kept intact ' Select Case strHex Case "0" getHexDec = 0 Case "1" getHexDec = 1 Case "2" getHexDec = 2 Case "3" getHexDec = 3 Case "4" getHexDec = 4 Case "5" getHexDec = 5 Case "6" getHexDec = 6 Case "7" getHexDec = 7 Case "8" getHexDec = 8 Case "9" getHexDec = 9 Case "A" getHexDec = 10 Case "B" getHexDec = 11 Case "C" getHexDec = 12 Case "D" getHexDec = 13 Case "E" getHexDec = 14 Case "F" getHexDec = 15 Case Else getHexDec = -1 End Select End Function Function getDecHex(strHex) ' Function Converts a single decimal value(0 - 15) into it's hex equivalent ' ' Written By: Mark Jager ' Written Date: 8/10/2000 ' ' Free to distribute as long as code is not modified, and header is kept intact ' Select Case CInt(strHex) Case 0 getDecHex = "0" Case 1 getDecHex = "1" Case 2 getDecHex = "2" Case 3 getDecHex = "3" Case 4 getDecHex = "4" Case 5 getDecHex = "5" Case 6 getDecHex = "6" Case 7 getDecHex = "7" Case 8 getDecHex = "8" Case 9 getDecHex = "9" Case 10 getDecHex = "A" Case 11 getDecHex = "B" Case 12 getDecHex = "C" Case 13 getDecHex = "D" Case 14 getDecHex = "E" Case 15 getDecHex = "F" Case Else getDecHex = "Z" End Select End Function Function BinaryShift(strBinary, intPos) ' Function circular left shifts a binary value n places ' ' Written By: Mark Jager ' Written Date: 8/10/2000 ' ' Free to distribute as long as code is not modified, and header is kept intact ' BinaryShift = Right(strBinary, Len(strBinary) - cint(intPos)) & _ Left(strBinary, cint(intPos)) End Function Function BinaryXOR(strBin1, strBin2) ' Function performs an exclusive or function on each position of two binary values ' ' Written By: Mark Jager ' Written Date: 8/10/2000 ' ' Free to distribute as long as code is not modified, and header is kept intact ' Dim strBinaryFinal Dim intPos For intPos = 1 To Len(strBin1) Select Case Mid(strBin1, cint(intPos), 1) Case Mid(strBin2, cint(intPos), 1) strBinaryFinal = strBinaryFinal & "0" Case Else strBinaryFinal = strBinaryFinal & "1" End Select Next BinaryXOR = strBinaryFinal End Function Function BinaryOR(strBin1, strBin2) ' Function performs an inclusive or function on each position of two binary values ' ' Written By: Mark Jager ' Written Date: 8/10/2000 ' ' Free to distribute as long as code is not modified, and header is kept intact ' Dim strBinaryFinal Dim intPos For intPos = 1 To Len(strBin1) If Mid(strBin1, cint(intPos), 1) = "1" Or Mid(strBin2, cint(intPos), 1) = "1" Then strBinaryFinal = strBinaryFinal & "1" Else strBinaryFinal = strBinaryFinal & "0" End If Next BinaryOR = strBinaryFinal End Function Function BinaryAND(strBin1, strBin2) ' Function performs an AND function on each position of two binary values ' ' Written By: Mark Jager ' Written Date: 8/10/2000 ' ' Free to distribute as long as code is not modified, and header is kept intact ' Dim strBinaryFinal Dim intPos For intPos = 1 To Len(strBin1) If Mid(strBin1, cint(intPos), 1) = "1" And Mid(strBin2, cint(intPos), 1) = "1" Then strBinaryFinal = strBinaryFinal & "1" Else strBinaryFinal = strBinaryFinal & "0" End If Next BinaryAND = strBinaryFinal End Function Function BinaryNOT(strBinary) ' Function makes each position of a binary value from 1 to 0 and 0 to 1 ' ' Written By: Mark Jager ' Written Date: 8/10/2000 ' ' Free to distribute as long as code is not modified, and header is kept intact ' Dim strBinaryFinal Dim intPos For intPos = 1 To Len(strBinary) If Mid(strBinary, cint(intPos), 1) = "1" Then strBinaryFinal = strBinaryFinal & "0" Else strBinaryFinal = strBinaryFinal & "1" End If Next BinaryNOT = strBinaryFinal End Function Function HexBlockToBinary(strHex) ' Function Converts a 8 digit/32 bit hex value to its 32 bit binary equivalent ' ' Written By: Mark Jager ' Written Date: 8/10/2000 ' ' Free to distribute as long as code is not modified, and header is kept intact ' Dim intPos Dim strTemp For intPos = 1 To Len(strHex) strTemp = strTemp & HexToBinary(Mid(strHex, cint(intPos), 1)) Next HexBlockToBinary = strTemp End Function %> <% '**************************************************************************************** '** Copyright Notice '** '** Web Wiz Mailing List '** http://www.webwizmailinglist.com '** '** Copyright ©2002-2006 Web Wiz. All Rights Reserved. '** '** THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS UNDER LICENSE FROM 'WEB WIZ'. '** '** IF YOU DO NOT AGREE TO THE LICENSE AGREEMENT THEN 'WEB WIZ' IS UNWILLING TO LICENSE '** THE SOFTWARE TO YOU, AND YOU SHOULD DESTROY ALL COPIES YOU HOLD OF 'WEB WIZ' SOFTWARE '** AND DERIVATIVE WORKS IMMEDIATELY. '** '** If you have not received a copy of the license with this work then a copy of the latest '** license contract can be found at:- '** '** http://www.webwizguide.com/license '** '** For more information about this software and for licensing information please contact '** 'Web Wiz' at the address and website below:- '** '** Web Wiz, Unit 10E, Dawkins Road Industrial Estate, Poole, Dorset, BH15 4JD, England '** http://www.webwizguide.com '** '** Removal or modification of this copyright notice will violate the license contract. '** '**************************************************************************************** 'Set the response buffer to true as we maybe redirecting Response.Buffer = True 'Reset server objects Set rsCommon = Nothing adoCon.Close Set adoCon = Nothing %> Mailing List: Privacy Statement <% '**************************************************************************************** '** Copyright Notice '** '** Web Wiz Rich Text Editor '** http://www.richtexteditor.org '** '** Copyright ©2001-2006 Web Wiz. All Rights Reserved. '** '** THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS UNDER LICENSE FROM 'WEB WIZ'. '** '** IF YOU DO NOT AGREE TO THE LICENSE AGREEMENT THEN 'WEB WIZ' IS UNWILLING TO LICENSE '** THE SOFTWARE TO YOU, AND YOU SHOULD DESTROY ALL COPIES YOU HOLD OF 'WEB WIZ' SOFTWARE '** AND DERIVATIVE WORKS IMMEDIATELY. '** '** If you have not received a copy of the license with this work then a copy of the latest '** license contract can be found at:- '** '** http://www.webwizguide.com/license '** '** For more information about this software and for licensing information please contact '** 'Web Wiz' at the address and website below:- '** '** Web Wiz, Unit 10E, Dawkins Road Industrial Estate, Poole, Dorset, BH15 4JD, England '** http://www.webwizguide.com '** '** Removal or modification of this copyright notice will violate the license contract. '** '**************************************************************************************** 'Uncomment the character set you require '(uncomment means remove the (') single quote from infront of the line) 'Western European ISO Const strPageEncoding = "iso-8859-1" 'Unicode UTF-8 'Const strPageEncoding = "utf-8" 'Arabic ISO 'Const strPageEncoding = "iso-8859-6" 'Arabic Windows 'Const strPageEncoding = "windows-1256" 'Baltic Windows 'Const strPageEncoding = "windows-1257" 'Central European DOS 'Const strPageEncoding = "ibm852" 'Central European ISO 'Const strPageEncoding = "iso-8859-2" 'Central European Windows 'Const strPageEncoding = "windows-1250" 'Chinese Simplified 'Const strPageEncoding = "gb2312" 'Chinese Simplified 'Const strPageEncoding = "hz-gb-2312" 'Chinese Traditional 'Const strPageEncoding = "big5" 'Cyrillic ISO 'Const strPageEncoding = "iso-8859-5" 'Cyrillic KOI8-R 'Const strPageEncoding = "koi8-r" 'Cyrillic KOI8-U 'Const strPageEncoding = "koi8-ru" 'Cyrillic Windows 'Const strPageEncoding = "windows-1251" 'Greek ISO 'Const strPageEncoding = "iso-8859-7" 'Greek Windows 'Const strPageEncoding = "windows-1253" 'Hebrew ISO-Logical 'Const strPageEncoding = "iso-8859-8-i" 'Hebrew ISO-Visual 'Const strPageEncoding = "iso-8859-8" 'Hebrew Windows 'Const strPageEncoding = "windows-1255" 'Japanese EUC 'Const strPageEncoding = "euc-jp" 'Japanese Shift-JIS 'Const strPageEncoding = "shift-jis" 'Korean 'Const strPageEncoding = "euc-kr" 'Thai Windows 'Const strPageEncoding = "windows-874" 'Turkish ISO 'Const strPageEncoding = "iso-8859-9" 'Vietnamese 'Const strPageEncoding = "windows-1258" 'Write the page encoding meta tage Response.Write("") %> <% '***** START WARNING - REMOVAL OR MODIFICATION OF THIS CODE WILL VIOLATE THE LICENSE AGREEMENT ****** '***** END WARNING - REMOVAL OR MODIFICATION OF THIS CODE WILL VIOLATE THE LICENSE AGREEMENT ****** %>
<% = strWebsiteName & "'s " & strTxtMailingList & " " & strTxtPrivacyStatement %>

<% = strTxtPrivacyStatement %>

<% = strPrivacyStatment %>

<% = strTxtIfYouWouldLikeToCreateEditOrCloseAMailingListAccountWith & " " & strWebsiteName & " " & strTxtThen %> <% = strTxtClickhere %>.

<% Response.Write("

") '***** START WARNING - REMOVAL OR MODIFICATION OF THIS CODE WILL VIOLATE THE LICENSE AGREEMENT ****** '***** END WARNING - REMOVAL OR MODIFICATION OF THIS CODE WILL VIOLATE THE LICENSE AGREEMENT ****** %>