<% @ Language=VBScript %> <% Option Explicit %> <% '**************************************************************************************** '** Copyright Notice '** '** Web Wiz Guide - Web Wiz Mailing List '** '** Copyright 2001-2005 Bruce Corkhill All Rights Reserved. '** '** This program is free software; you can modify (at your own risk) any part of it '** under the terms of the License that accompanies this software and use it both '** privately and commercially. '** '** All copyright notices must remain in tacked in the scripts and the '** outputted HTML. '** '** You may use parts of this program in your own private work, but you may NOT '** redistribute, repackage, or sell the whole or any part of this program even '** if it is modified or reverse engineered in whole or in part without express '** permission from the author. '** '** You may not pass the whole or any part of this application off as your own work. '** '** All links to Web Wiz Guide and powered by logo's must remain unchanged and in place '** and must remain visible when the pages are viewed unless permission is first granted '** by the copyright holder. '** '** This program is distributed in the hope that it will be useful, '** but WITHOUT ANY WARRANTY; without even the implied warranty of '** MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE OR ANY OTHER '** WARRANTIES WHETHER EXPRESSED OR IMPLIED. '** '** You should have received a copy of the License along with this program; '** if not, write to:- Web Wiz Guide, PO Box 4982, Bournemouth, BH8 8XP, United Kingdom. '** '** '** No official support is available for this program but you may post support questions at: - '** http://www.webwizguide.info/forum '** '** Support questions are NOT answered by e-mail ever! '** '** For correspondence or non support questions contact: - '** info@webwizguide.info '** '** or at: - '** '** Web Wiz Guide, PO Box 4982, Bournemouth, BH8 8XP, United Kingdom '** '**************************************************************************************** 'Set the response buffer to true as we maybe redirecting Response.Buffer = True 'Declare variables Dim strEmail 'Holds the users e-mail address Dim strUserName 'Holds the members name Dim strPassword 'Holds the user password Dim blnHTMLformat 'Set to true if email is to be in HTML format Dim strMessage 'Holds the error message if the user is not entered into the database Dim strUserCode 'Holds a unique code for the new list member Dim blnEmailOK 'Set to true if the email address is valid Dim lngMemberID 'Holds the members ID number Dim laryCatID 'Holds the cat ID Dim blnChecked 'Set to true if the category checkbox is to be checked Dim blnEmailExists 'Set to true if the email address is already in the database Dim strSubject 'Holds the subject of te email Dim strEmailBody 'Holds the email body Dim strSaltValue 'Holds the salt value for ecrypted passwords Dim blnEmailBanned 'Holds if the email address or domain are banned Dim strCheckEmailAddress'Holds the banned email address list to check Dim strBlockedEmailAddress 'Hoilds the blocked email address 'Initialise variables blnEmailOK = True blnEmailExists = false blnEmailBanned = false lngMemberID = 0 'Read in the email address strEmail = Trim(Mid(LCase(Request("email")), 1, 50)) 'Clean up the email address address getting rid of unwanted characters strEmail = characterStrip(strEmail) 'Read in the form details If Request.Form("postBack") Then 'Check to see if the user has entered an e-mail address and that it is a valid address If Len(strEmail) < 5 OR NOT Instr(1, strEmail, " ") = 0 OR InStr(1, strEmail, "@", 1) < 2 OR InStrRev(strEmail, ".") < InStr(1, strEmail, "@", 1) Then 'Set an error message if the users has not enetered a valid e-mail address blnEmailOK = False 'Else the email address is OK Else blnEmailOK = True End If 'Read in the form details strUserName = removeAllTags(Trim(Mid(Request.Form("name"), 1, 25))) strPassword = removeAllTags(Trim(Mid(Request.Form("password"), 1, 25))) If blnPlainTextOption = true Then blnHTMLformat = CBool(Request.Form("HTMLformat")) Else blnHTMLformat = true 'Check to see if the email address or email domain entered is banned 'Initalise the strSQL variable with an SQL statement to query the database strSQL = "SELECT " & strDbTable & "EmailBanList.Email FROM " & strDbTable & "EmailBanList;" 'Query the database rsCommon.Open strSQL, adoCon 'If records are returned check-em out 'Loop through the email address and check 'em out Do while NOT rsCommon.EOF 'Read in the email address to check strCheckEmailAddress = rsCommon("Email") 'If a whildcard character is found then check that If Instr(1, strCheckEmailAddress, "*", 1) > 0 Then 'Remove the wildcard charcter from the email address to check strCheckEmailAddress = Replace(strCheckEmailAddress, "*", "", 1, -1, 1) 'If the banned email and the email entered match up then don't let em sign up If InStr(1, strEmail, strCheckEmailAddress, 1) Then blnEmailBanned = True strBlockedEmailAddress = rsCommon("Email") End If 'Else check the actual name doesn't match Else 'If the banned email and the email entered match up then don't let em sign up If strCheckEmailAddress = strEmail Then blnEmailBanned = True strBlockedEmailAddress = strCheckEmailAddress End If End If 'Move to the next record rsCommon.MoveNext Loop 'Close recordset rsCommon.Close End If 'If this is a post back run the add new or update code If Request.Form("postBack") AND blnEmailOK AND strUserName <> "" AND strPassword <> "" AND blnEmailBanned = false Then 'Initalise the strSQL variable with an SQL statement to query the database strSQL = "SELECT " & strDbTable & "Members.* FROM " & strDbTable & "Members;" With rsCommon 'Set the cursor type property of the record set to Dynamic so we can navigate through the record set .CursorType = 2 'Set the Lock Type for the records so that the record set is only locked when it is updated .LockType = 3 'Query the database .Open strSQL, adoCon 'Calculate a code for the user strUserCode = hexValue(20) 'Loop through all the records in the recordset to check that the user id and the email address are not already in the database Do While NOT .EOF 'If there is no user code or it is already in the database make a new one and serch the recordset from the begining again If strUserCode = .fields("ID_Code") Then 'Calculate a code for the user strUserCode = hexValue(20) 'Move to the first record to make sure the new user code is not in the database .MoveFirst End If 'If the e-mail address is already in the database then this is an update so exit loop If strEmail = .fields("Email") Then 'Set the blnEmailExists variable to true blnEmailExists = true 'Exit the for loop Exit Do End If 'Move to the next record in the recordset .MoveNext Loop 'If the email doesn't already exsist then enter the email into the database If blnEmailExists = False Then 'Encrypt password If blnEncryptPasswords Then 'generate a salt value strSaltValue = hexValue(Len(strPassword)) 'Concatenate salt value to the password strPassword = strPassword & strSaltValue 'Encrypt the password strPassword = HashEncode(strPassword) End If 'Add new record to a new recorset .AddNew 'Set database fields .Fields("Email") = strEmail .Fields("Name") = strUserName .Fields("Password") = strPassword If blnEncryptPasswords Then .Fields("Salt") = strSaltValue .Fields("ID_Code") = strUserCode .Fields("HTMLformat") = blnHTMLformat .Fields("Active") = False 'Update the database .Update 'Requery database to get the new id number .Requery 'Move to the last record .MoveLast 'Get the id number lngMemberID = CLng(.fields("Mail_ID")) End If 'Reset recordset variable .Close End With 'If the email doesn't already exsist then enter the categoriy details into the database If blnEmailExists = False Then 'Add the category details to the database For each laryCatID in Request.Form("catID") 'Add cat choices strSQL = "INSERT INTO " & strDbTable & "MemCat " & _ "(" & _ "[Mail_ID], " & _ "[Cat_ID] " & _ ") " & _ "VALUES " & _ "('" & lngMemberID & "', " & _ "'" & CLng(laryCatID) & "' " & _ ")" 'Write to database adoCon.Execute(strSQL) Next 'If email activation of account is enabled then get send an activation email If blnActivate Then 'Set the subject of the email strSubject = strWebsiteName & ": " & strTxtConformYourSubscriptionToMailingList 'set the message body of the activation email strEmailBody = strTxtHi & " " & strUserName & "," & _ vbCrLf & vbCrLf & strTxtGreetingsFrom & " " & strWebsiteName & "." & _ vbCrLf & vbCrLf & strTxtWeReceivedYourRequestToSubscribe & " " & strWebsiteName & " " & strTxtMailingList & "." & _ vbCrLf & vbCrLf & strTxtToActivateYourSubscriptionClickTheAddressBelow & ":-" & _ vbCrLf & vbCrLf & strWebsiteAddress & "/activate.asp?ID=" & strUserCode & _ vbCrLf & vbCrLf & strTxtIfYouDidNotSubscribe & "." & _ vbCrLf & vbCrLf & strTxtThankYouForYourInterest & "." & _ vbCrLf & vbCrLf & strSignature 'Create email object Call createMailObject(strMailComponent) '***** START WARNING - REMOVAL OR MODIFICATION OF THIS CODE WILL VIOLATE THE LICENSE AGREEMENT ****** 'Write a remove from mailing list message to add to the end of the e-mail in HTML Format strEmailBody = strEmailBody & mailBody("text", strEmail, blnLCode) '***** END WARNING - REMOVAL OR MODIFICATION OF THIS CODE WILL VIOLATE THE LICENSE AGREEMENT ****** 'Send the email Call SendMail(strUserName, strEmail, strMailComponent, "text") 'Drop email component Call dropMailObject(strMailComponent) 'Clean up Set rsCommon = Nothing adoCon.Close Set adoCon = Nothing 'Redirect to actiavtion page Response.Redirect("activate_confirm.asp?email=" & Server.URLEncode(strEmail)) End If 'Clean up Set rsCommon = Nothing adoCon.Close Set adoCon = Nothing 'Redirect to actiavtion page Response.Redirect("activate.asp?ID=" & strUserCode) End If End If %> Mailing List: Maak een Account
<% = strWebsiteName & "'s " & strTxtMailingList & " " & strTxtCreateAccount %>
<% 'If there is a problem tell the user If blnEmailOK = false OR blnEmailExists OR blnEmailBanned OR (Request.Form("postBack") AND (strUserName = "" OR strPassword = "")) Then %>

<% = strTxtYourSubscriptionRequestCouldNotBeProcessed %>.
<% If blnEmailOK = false Then Response.Write(strTxtEmailAdressNotValid & ".") ElseIf blnEmailBanned Then Response.Write(strTxtTheEmailAddressOrDomainEntered & ", " & strBlockedEmailAddress & ", " & strTxtIsNotPermittedPleaseEnterNew & ".") ElseIf blnEmailExists Then Response.Write(strTxtTheEmailAddressYouEntered & ", " & strEmail & " " & strTxtIsAlreadySubscribedPlease & " " & strTxtClickhere & " " & strTxtToLogInWithThisAddressToEditAccount & ".") ElseIf strUserName = "" Then Response.Write(strTxtPleaseEnterAValidName& ".") ElseIf strPassword = "" Then Response.Write(strTxtPleaseEnterAValidPassword& ".") End If %>
<% End If %>
<% 'If the user can choose to have a plain text email sent give them the option If blnPlainTextOption Then %> <% End If %>
<% = strTxtNewAccountDetails %> (<% = strTxtAllFieldsAreRequired %>)
<% = strTxtPleaseRegisterToActivateYourMailingListSubscription & " " & strWebsiteName & " " & strTxtFeaturesAndNewsYouCanUnsubscribe %>.
<% = strTxtName %>:
<% = strTxtEmailAddress %>:
<% = strTxtPassword %>:
<% = strTxtConfirmPassword %>:
<% = strTxtEmailDeliveryFormat %>: <% = strTxtHTML %>  <% = strTxtPlainText %>
 




<% = strTxtPrivacyStatement %>
<% Response.Write("
") '***** START WARNING - REMOVAL OR MODIFICATION OF THIS CODE WILL VIOLATE THE LICENSE AGREEMENT ****** If blnLCode Then Response.Write("Powered by Web Wiz Mailing List version " & strVersion & "") Response.Write("
Copyright ©2001-2005 Web Wiz Guide") End If '***** END WARNING - REMOVAL OR MODIFICATION OF THIS CODE WILL VIOLATE THE LICENSE AGREEMENT ****** %>