register.asp

代码名称： Snitz Forums 2000 代码语言： 英文 代码类型： 国外代码 运行环境： ASP 授权方式： 免费代码 代码大小： 530kb 代码等级： 3 整

				'## E-mails Message to the Author of this Reply.
				strRecipientsName = Request.Form("Name")
				strRecipients = Request.Form("Email")
				strFrom = strSender
				strFromName = strForumTitle
				strsubject = strForumTitle & " Registration "
				strMessage = "Hello " & Request.Form("name") & vbNewline & vbNewline
				strMessage = strMessage & "You received this message from " & strForumTitle & " because you have registered for a new account which allows you to post new messages and reply to existing ones on the forums at " & strForumURL & vbNewline & vbNewline
				if strAuthType="db" then
				'################################### E-mail Validation Mod #################################
					if strEmailVal = "1" then
						strMessage = strMessage & "Please click on the link below to complete your registration." & vbNewline & vbNewLine
						strMessage = strMessage & "If the link is split or broken, you will need to copy and paste the entire link into your web browser." & vbNewline & vbNewLine
						strMessage = strMessage & strForumURL & "register.asp?actkey=" & actkey & vbNewline & vbNewline
					else
				'######################################################################################
						strMessage = strMessage & "Password: " & Request.Form("Password") & vbNewline & vbNewline
					end if '<---- E-mail Validation Mod - 1 line #############
				end if
				strMessage = strMessage & "You can change your information at our website by selecting the ""Profile"" link." & vbNewline & vbNewline
				strMessage = strMessage & "Happy Posting!"
%>
<!--#INCLUDE FILE="inc_mail.asp" -->
<%
			end if
		else
			Response.Write	"      <p align=""center""><font face=""" & strDefaultFontFace & """ size=""" & strHeaderFontSize & """ color=""" & strHiLiteFontColor & """>There Was A Problem With Your Details</font></p>" & vbNewLine & _
					"      <table align=""center"" border=""0"">" & vbNewLine & _
					"        <tr>" & vbNewLine & _
					"          <td><font face=""" & strDefaultFontFace & """ size=""" & strDefaultFontSize & """ color=""" & strHiLiteFontColor & """><ul>" & Err_Msg & "</ul></font></td>" & vbNewLine & _
					"        </tr>" & vbNewLine & _
					"      </table>" & vbNewLine & _
					"      <p align=""center""><font face=""" & strDefaultFontFace & """ size=""" & strDefaultFontSize & """><a href=""JavaScript:history.go(-1)"">Go Back To Enter Data</a></font></p>" & vbNewLine
			WriteFooter
			Response.End 
		end if
		' ##################### E-mail Validation Mod #########################
		if lcase(strEmail) = "0" then
			Response.Write	"      <p align=""center""><font face=""" & strDefaultFontFace & """ size=""" & strHeaderFontSize & """>Your Registration Has Been Completed!</font></p>" & vbNewLine & _
					"      <p align=""center""><font face=""" & strDefaultFontFace & """ size=""" & strDefaultFontSize & """>You may now begin posting"
			if strAuthType = "db" then Response.Write(" using your new UserName and Password")
			Response.Write	".</font></p>" & vbNewLine
	 	else
			if strEmailVal = "1" then
				Response.Write	"      <p align=""center""><font face=""" & strDefaultFontFace & """ size=""" & strHeaderFontSize & """>Your Registration Is Almost Complete!</font></p>" & vbNewLine
			'#######################################
				if strRestrictReg = "1" then
					Response.Write	"      <p align=""center""><font face=""" & strDefaultFontFace & """ size=""" & strDefaultFontSize & """>The Administrator has restricted registration on this forum. You will receive an e-mail as soon as the Administrator approves your request.</font></p>" & vbNewLine
				else
					Response.Write	"      <p align=""center""><font face=""" & strDefaultFontFace & """ size=""" & strDefaultFontSize & """>Please follow the instructions in the e-mail that has been sent to <b>" & ChkString(Request.Form("Email"),"email") & "</b> to complete your registration.</font></p>" & vbNewLine
				end if
			'#######################################
		 	else
				Response.Write	"      <p align=""center""><font face=""" & strDefaultFontFace & """ size=""" & strHeaderFontSize & """>Your Registration Has Been Completed!</font></p>" & vbNewLine & _
						"      <p align=""center""><font face=""" & strDefaultFontFace & """ size=""" & strDefaultFontSize & """>You may now begin posting"
				if strAuthType = "db" then Response.Write(" using your new UserName and Password")
				Response.Write	".</font></p>" & vbNewLine
			end if
	 	end if
		' #######################################################################

		if strAuthType = "db" then

			select case chkUser(Request.Form("Name"), Request.Form("Password"),-1)
				case 1, 2, 3, 4
					Call DoCookies("false")
					strLoginStatus = 1
				case else
					strLoginStatus = 0
			end select
		end if

		if strAutoLogon = 1 then
  			Response.Redirect "default.asp"
		else
			Response.Write	"      <meta http-equiv=""Refresh"" content=""5; URL=" & chkString(Request.Form("refer"),"refer") & """>" & vbNewLine
		end if
		Response.Write	"      <p align=""center""><font face=""" & strDefaultFontFace & """ size=""" & strDefaultFontSize & """><a href=""" & chkString(Request.Form("refer"),"refer") & """>Back To Forum</a></font></p>" & vbNewLine
	end if 
else
	Response.Write	"    <br /><p align=""center""><font face=""" & strDefaultFontFace & """ size=""" & strHeaderFontSize & """ color=""" & strHiLiteFontColor & """>Sorry, we are not accepting any new Members at this time.</font></p>" & vbNewLine & _
			"    <meta http-equiv=""Refresh"" content=""5; URL=default.asp"">" & vbNewLine & _
			"    <p align=""center""><font face=""" & strDefaultFontFace & """ size=""" & strDefaultFontSize & """><a href=""default.asp"">Back To Forum</a></font></p><br />" & vbNewLine
end if
WriteFooter
Response.End

sub DoCount
	'## Forum_SQL - Updates the Totals table by adding 1 to U_COUNT
	strSql = "UPDATE " & strTablePrefix & "TOTALS "
	strSql = strSql & " SET " & strTablePrefix & "TOTALS.U_COUNT = " & strTablePrefix & "TOTALS.U_COUNT + 1"
	my_Conn.Execute (strSql),,adCmdText + adExecuteNoRecords
end sub

sub ShowForm()
	Response.Write	"      <form action=""register.asp?mode=DoIt"" method=""Post"" id=""Form1"" name=""Form1"">" & vbNewLine & _
			"      <input name=""Refer"" type=""hidden"" value=""" & chkString(Request.Form("Refer"),"refer") & """>" & vbNewLine & _
			"      <table width=""400"" border=""0"" align=""center"">" & vbNewLine & _
			"        <tr>" & vbNewLine & _
			"          <td>" & vbNewLine
Call DisplayProfileForm
	Response.Write	"          </td>" & vbNewLine & _
			"        </tr>" & vbNewLine & _
			"      </table>" & vbNewLine & _
			"      </form>" & vbNewLine
end sub

Function IsValidURL(sValidate)
	Dim sInvalidChars
	Dim bTemp
	Dim i

	if trim(sValidate) = "" then IsValidURL = true : exit function
	sInvalidChars = """;+()*'<>"
	for i = 1 To Len(sInvalidChars)
		if InStr(sValidate, Mid(sInvalidChars, i, 1)) > 0 then bTemp = True
		if bTemp then strURLError = "<br />&bull;&nbsp;cannot contain any of the following characters:  "" ; + ( ) * ' < > "
		if bTemp then Exit For
	next
	if not bTemp then
		for i = 1 to Len(sValidate)
			if Asc(Mid(sValidate, i, 1)) = 160 then bTemp = True
			if bTemp then strURLError = "<br />&bull;&nbsp;cannot contain any spaces "
			if bTemp then Exit For
		next
	end if

	' extra checks
	' check to make sure URL begins with http:// or https://
	if not bTemp then
		bTemp = (lcase(left(sValidate, 7)) <> "http://") and (lcase(left(sValidate, 8)) <> "https://")
		if bTemp then strURLError = "<br />&bull;&nbsp;must begin with either http:// or https:// "
	end if
	' check to make sure URL is 255 characters or less
	if not bTemp then
		bTemp = len(sValidate) > 255
		if bTemp then strURLError = "<br />&bull;&nbsp;cannot be more than 255 characters "
	end if
	' no two consecutive dots
	if not bTemp then
		bTemp = InStr(sValidate, "..") > 0
		if bTemp then strURLError = "<br />&bull;&nbsp;cannot contain consecutive periods "
	end if
	'no spaces
	if not bTemp then
		bTemp = InStr(sValidate, " ") > 0
		if bTemp then strURLError = "<br />&bull;&nbsp;cannot contain any spaces "
	end if
	if not bTemp then
		bTemp = (len(sValidate) <> len(Trim(sValidate)))
		if bTemp then strURLError = "<br />&bull;&nbsp;cannot contain any spaces "
	end if 'Addition for leading and trailing spaces

	' if any of the above are true, invalid string
	IsValidURL = Not bTemp
End Function

Function IsValidString(sValidate)
	Dim sInvalidChars
	Dim bTemp
	Dim i 
	' Disallowed characters
	sInvalidChars = "!#$%^&*()=+{}[]|\;:/?>,<'"
	for i = 1 To Len(sInvalidChars)
		if InStr(sValidate, Mid(sInvalidChars, i, 1)) > 0 then bTemp = True
		if bTemp then Exit For
	next
	for i = 1 to Len(sValidate)
		if Asc(Mid(sValidate, i, 1)) = 160 then bTemp = True
		if bTemp then Exit For
	next

	' extra checks
	' no two consecutive dots or spaces
	if not bTemp then
		bTemp = InStr(sValidate, "..") > 0
	end if
	if not bTemp then
		bTemp = InStr(sValidate, "  ") > 0
	end if
	if not bTemp then
		bTemp = (len(sValidate) <> len(Trim(sValidate)))
	end if 'Addition for leading and trailing spaces

	' if any of the above are true, invalid string
	IsValidString = Not bTemp
End Function

function chkNameFilter(pString)
	if trim(Application(strCookieURL & "STRFILTERUSERNAMES")) = "" then
		txtUserNames = ""
		'## Forum_SQL - Get UserNames from DB
		strSqln = "SELECT N_NAME " 
		strSqln = strSqln & " FROM " & strFilterTablePrefix & "NAMEFILTER "

		set rsUName = Server.CreateObject("ADODB.Recordset")
		rsUName.open strSqln, my_Conn, adOpenForwardOnly, adLockReadOnly, adCmdText

		if rsUName.EOF then
			recUserNameCount = ""
		else
			allUserNameData = rsUName.GetRows(adGetRowsRest)
			recUserNameCount = UBound(allUserNameData,2)
		end if

		rsUName.close
		set rsUName = nothing

		if recUserNameCount <> "" then
			nNAME = 0

			for iUserName = 0 to recUserNameCount
				UserNameName = allUserNameData(nNAME,iUserName)
				if txtUserNames = "" then
					txtUserNames = UserNameName
				else
					txtUserNames = txtUserNames & "," & UserNameName
				end if
			next
		end if
		Application.Lock
		Application(strCookieURL & "STRFILTERUSERNAMES") = txtUserNames
		Application.UnLock
	end if
	txtUserNames = Application(strCookieURL & "STRFILTERUSERNAMES")
	fString = trim(pString)
	unames = split(txtUserNames, ",")
	for i = 0 to ubound(unames)
		if instr(1,lcase(fString), lcase(unames(i)),1) <> 0 then
			Err_Msg = Err_Msg & "<li>Username may not contain the word <b>" & unames(i) & "</b></li>"
			exit function
		end if
	next
end function

function chkNameBadWords(pString)
	if trim(Application(strCookieURL & "STRBADWORDWORDS")) = "" or trim(Application(strCookieURL & "STRBADWORDREPLACE")) = "" then
		txtBadWordWords = ""
		txtBadWordReplace = ""
		'## Forum_SQL - Get Badwords from DB
		strSqlb = "SELECT B_BADWORD, B_REPLACE " 
		strSqlb = strSqlb & " FROM " & strFilterTablePrefix & "BADWORDS "

		set rsBadWord = Server.CreateObject("ADODB.Recordset")
		rsBadWord.open strSqlb, my_Conn, adOpenForwardOnly, adLockReadOnly, adCmdText

		if rsBadWord.EOF then
			recBadWordCount = ""
		else
			allBadWordData = rsBadWord.GetRows(adGetRowsRest)
			recBadWordCount = UBound(allBadWordData,2)
		end if

		rsBadWord.close
		set rsBadWord = nothing

		if recBadWordCount <> "" then
			bBADWORD = 0
			bREPLACE = 1

			for iBadword = 0 to recBadWordCount
				BadWordWord = allBadWordData(bBADWORD,iBadWord)
				BadWordReplace = allBadWordData(bREPLACE,iBadWord)
				if txtBadWordWords = "" then
					txtBadWordWords = BadWordWord
					txtBadWordReplace = BadWordReplace
				else
					txtBadWordWords = txtBadWordWords & "," & BadWordWord
					txtBadWordReplace = txtBadWordReplace & "," & BadWordReplace
				end if
			next
		end if
		Application.Lock
		Application(strCookieURL & "STRBADWORDWORDS") = txtBadWordWords
		Application(strCookieURL & "STRBADWORDREPLACE") = txtBadWordReplace
		Application.UnLock
	end if
	txtBadWordWords = Application(strCookieURL & "STRBADWORDWORDS")
	fString = trim(pString)
	bwords = split(txtBadWordWords, ",")
	for i = 0 to ubound(bwords)
		if instr(1,lcase(fString), lcase(bwords(i)),1) <> 0 then
			Err_Msg = Err_Msg & "<li>Username may not contain the word <b>" & bwords(i) & "</b></li>"
			exit function
		end if
	next
end function
%>