<%@LANGUAGE="VBSCRIPT" CODEPAGE="1252"%>
<%
DIM pref_paypal_account, LOG_FILE, VENDOR_IDENTITY, VENDOR_NAME, VENDOR_EMAIL, VENDOR_EMAIL_CC, VENDOR_EMAIL_BCC, DATABASE_PATH, MM_connection_STRING
'*** CHANGE THE FOLLOWIN TO YOUR OWN CONFIGURATION ***
pref_paypal_account = "services@ericthetrainer.com"
pref_private_path = "../private"
paypal_notify_url = "http://www.EricTheTrainer.com/ipn_processor.asp"
return_url = "http://www.ericthetrainer.com/purchase_confirm.asp"
cancel_url = "http://www.ericthetrainer.com/purchase_cancel.asp"
login_url = "http://www.EricTheTrainer.com/login.asp"
VENDOR_NAME = "ERIC THE TRAINER" '*--> NAME OF YOUR COMPANY
VENDOR_EMAIL = "services@ericthetrainer.com" '*--> YOUR PRIMARY EMAIL REGISTERED WITH PAYPAL
VENDOR_EMAIL_CC = "" '*--> CC EMAIL - FOR ADDITIONAL NOTIFICATION EMAIL - OPTIONAL
VENDOR_EMAIL_BCC = "" '*--> BCC EMAIL - FOR ADDITIONAL NOTIFICATION EMAIL - OPTIONAL
CONST TERMINATE_ON_SYSTEM_ERROR = FALSE '*IF THERE IS A SERIOUS SYSTEM ERROR TRAPPED BY THE SYSTEM SUCH AS FAILURE TO
'*CREATE A SERVER OBJECT, YOU MAY CHOOSE TO TERMINATE THE SCRIPT RIGHT AWAY.
'*JUST SET TERMINATE_ON_SYSTEM_ERROR TO "TRUE"
CONST AUDIT_TRAIL_ON = False ' SET THIS TO TRUE TO ENABLE TEXT LOG FILE
LOG_FILE = "PAYPAL.txt" '*PAYPAL AUDIT TRAIL LOG FILE
'*NOTE: FOR ADDED SECURITY, IT IS BEST TO STORE THE LOG FILE OUTSIDE THE ROOT FOLDER
'*EX. "../Private/paypal.txt" --> here folder "Private" is outside the HTTP REACH
const remote_admin_login = "ett"
const remote_admin_password = "ettadmin"
%>
<%
'Dim MM_connection_STRING
'dim DB
'editted MapPath and removed .. from "../private/ett_db.mdb"
'the ".." convention is not available
'DB = Server.MapPath("/private/ett_db.mdb")
DB = Server.MapPath("/access_db/ett_db.mdb")
'MM_connection_STRING = "Provider=MSDASQL; Driver={Microsoft Access Driver (*.mdb)}; DBQ=" & DB
MM_connection_STRING = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & DB
%>
<%
'1. function parse (str) : parse all incoming submissions
'2. function unparse (str) : opposite of parse
'3. function record_exists( tbl_name, column_name, the_value)
' : checks for duplicate record based on 1 primary column -- used in adding records
'4. function record_exists_ext( tbl_name, column_name_1, column_name_2, the_value_1, the_value_2)
' : checks for duplicate record based on 2 columns -- used in updating records
'5. function insert_command(tbl_name, arr_cols, arr_values)
' : constructs an insert command
' : makes insertions of quotes and commas a breeze
'6. function update_command(tbl_name, idcol, idval, arr_cols, arr_values)
' : constructs and edit command
' : makes insertions of quotes and commas a breeze
%>
<%
function parse (str)
parse = trim(replace(replace(str, "'", "''"), "|", ""))
end function
function unparse (str)
if str <> "" then
unparse = trim(replace(str, "''", "'"))
else
unparse = ""
end if
end function
function record_exists( tbl_name, column_name, the_value, isInteger)
Dim quote
quote = "'"
if isInteger=1 then quote = ""
Set rs = Server.CreateObject("ADODB.Recordset")
rs.ActiveConnection = MM_Connection_STRING
rs.Source = "SELECT * FROM " & tbl_name & " WHERE " & column_name & " = " & quote & the_value & quote
'response.write rs.Source
'response.End()
rs.CursorType = 0
rs.CursorLocation = 2
rs.LockType = 1
rs.Open()
if rs.eof then
record_exists = false
else
record_exists = true
end if
rs.Close()
Set rs = Nothing
end function
function record_exists_ext( tbl_name, column_name_1, column_name_2, the_value_1, value_1_isInt, the_value_2, value_2_isInt)
Dim quote1
Dim quote2
quote1 = "'"
quote2 = "'"
if value_1_isInt = 1 then quote1 = ""
if value_2_isInt = 1 then quote2 = ""
Set rs = Server.CreateObject("ADODB.Recordset")
rs.ActiveConnection = MM_Connection_STRING
rs.Source = "SELECT * FROM " & tbl_name & " WHERE " & column_name_1 & " = " & quote1 & the_value_1 & quote1 & " AND " & column_name_2 & " = " & quote2 & the_value_2 & quote2
' response.write rs.Source
' response.end()
rs.CursorType = 0
rs.CursorLocation = 2
rs.LockType = 1
rs.Open()
if rs.eof then
record_exists_ext = false
else
record_exists_ext = true
end if
rs.Close()
Set rs = Nothing
end function
function record_exists_edit_level_1( tbl_name, column_name_1, column_name_2, the_value_1, value_1_isInt, the_value_2, value_2_isInt)
Dim quote1
Dim quote2
quote1 = "'"
quote2 = "'"
if value_1_isInt = 1 then quote1 = ""
if value_2_isInt = 1 then quote2 = ""
Set rs = Server.CreateObject("ADODB.Recordset")
rs.ActiveConnection = MM_Connection_STRING
rs.Source = "SELECT * FROM " & tbl_name & " WHERE " & column_name_1 & " = " & quote1 & the_value_1 & quote1 & " AND " & column_name_2 & " <> " & quote2 & the_value_2 & quote2
' response.write rs.Source
' response.end()
rs.CursorType = 0
rs.CursorLocation = 2
rs.LockType = 1
rs.Open()
if rs.eof then
record_exists_edit_level_1 = false
else
record_exists_edit_level_1 = true
end if
rs.Close()
Set rs = Nothing
end function
function record_exists_edit_level_2( tbl_name, column_name_1, column_name_2, column_name_3, the_value_1, value_1_isInt, the_value_2, value_2_isInt, the_value_3, value_3_isInt)
Dim quote1
Dim quote2
quote1 = "'"
quote2 = "'"
quote3 = "'"
if value_1_isInt = 1 then quote1 = ""
if value_2_isInt = 1 then quote2 = ""
if value_3_isInt = 1 then quote3 = ""
Set rs = Server.CreateObject("ADODB.Recordset")
rs.ActiveConnection = MM_Connection_STRING
rs.Source = "SELECT * FROM " & tbl_name & " WHERE " & column_name_1 & " = " & quote1 & the_value_1 & quote1 & " AND " & column_name_2 & " <> " & quote2 & the_value_2 & quote2 & " AND " & column_name_3 & " = " & quote3 & the_value_3 & quote3
' response.write rs.Source
' response.end()
rs.CursorType = 0
rs.CursorLocation = 2
rs.LockType = 1
rs.Open()
if rs.eof then
record_exists_edit_level_2 = false
else
record_exists_edit_level_2 = true
end if
rs.Close()
Set rs = Nothing
end function
function insert_command(tbl_name, arr_cols, arr_values)
dim i
cols = split(arr_cols, "|")
vals = split(arr_values, "|")
ub_arr = ubound(cols)
str = "INSERT INTO " & tbl_name & "("
scol = ""
sval = ""
for i = 0 to ub_arr
if i < ub_arr then
scol = scol & cols(i) & ","
sval = sval & "'" & vals(i) & "',"
else
scol = scol & cols(i)
sval = sval & "'" & vals(i) & "'"
end if
next
str = str & scol & ") VALUES (" & sval & ")"
insert_command = str
end function
function update_command(tbl_name, idcol, idcol_isInt, idval, arr_cols, arr_values)
dim i
if idcol_isInt = 1 then
quote1 = ""
else
quote1 = "'"
end if
cols = split(arr_cols, "|")
vals = split(arr_values, "|")
ub_arr = ubound(cols)
str = "UPDATE " & tbl_name & " SET "
s = ""
for i = 0 to ub_arr
if i < ub_arr then
s = s & cols(i) & "='" & vals(i) & "',"
else
s = s & cols(i) & "='" & vals(i) & "'"
end if
next
str = str & s & " WHERE " & idcol & "=" & quote1 & idval & quote1
update_command = str
end function
function update_all_command(tbl_name, arr_cols, arr_values)
dim i
cols = split(arr_cols, "|")
vals = split(arr_values, "|")
ub_arr = ubound(cols)
str = "UPDATE " & tbl_name & " SET "
s = ""
for i = 0 to ub_arr
if i < ub_arr then
s = s & cols(i) & "='" & vals(i) & "',"
else
s = s & cols(i) & "='" & vals(i) & "'"
end if
next
str = str & s & " "
update_all_command = str
end function
function delete_command(tbl_name, idcol, idval )
if isnumeric(idval) then
str = "DELETE FROM " & tbl_name & " WHERE " & idcol & "=" & idval
else
str = "DELETE FROM " & tbl_name & " WHERE " & idcol & "='" & idval & "'"
end if
delete_command = str
end function
Function IsValidEmail(sText)
'validate email address
Dim i
Dim iTmpChar
Dim sDomainExt
Dim vEmail
Dim vDomain
IsValidEmail = False
'check for 1 @ symbol
vEmail = Split(sText, "@")
If UBound(vEmail) <> 1 Then Exit Function
If vEmail(0) = "" Or vEmail(1) = "" Then Exit Function
'validate account
For i = 1 To Len(vEmail(0))
'check for valid characters
iTmpChar = Asc(Mid(LCase(vEmail(0)), i, 1))
'test for letters
If Not (iTmpChar >= Asc("a")) And (iTmpChar <= Asc("z")) Then
'test for numbers
If Not IsNumeric(Chr(iTmpChar)) Then
'test for exceptions
If Chr(iTmpChar) <> "." And Chr(iTmpChar) <> "_" And Chr(iTmpChar) <> "-" Then Exit Function
End If
End If
Next
'validate domain
For i = 1 To Len(vEmail(1))
'check for valid characters
iTmpChar = Asc(Mid(LCase(vEmail(1)), i, 1))
'test for letters
If Not (iTmpChar >= Asc("a")) And (iTmpChar <= Asc("z")) Then
'test for numbers
If Not IsNumeric(Chr(iTmpChar)) Then
'test for exceptions
If Chr(iTmpChar) <> "." And Chr(iTmpChar) <> "-" Then Exit Function
End If
End If
Next
'validate domain extension
vDomain = Split(vEmail(1), ".")
sDomainExt = vDomain(UBound(vDomain))
If Len(sDomainExt) < 2 Or Len(sDomainExt) > 4 Then Exit Function
'test for letters
For i = 1 To Len(sDomainExt)
iTmpChar = Asc(Mid(LCase(sDomainExt), i, 1))
If Not (iTmpChar >= Asc("a")) And (iTmpChar <= Asc("z")) Then Exit Function
Next
IsValidEmail = True
End Function
%>
<%
dim error_msg
dim login
chk = request("chk")
if request("logout") <> "" then
session("memberid") = ""
session("login") = ""
session("firstname") = ""
end if
login = request("login")
password = request("password")
submit = request("submit")
if submit <> "" then
session("memberid") = ""
session("login") = ""
session("firstname") = ""
' if login = "" then pusherror "Invalid login id."
Set rslogin = Server.CreateObject("ADODB.Recordset")
rslogin.ActiveConnection = MM_connection_STRING
rslogin.Source = "SELECT * FROM tbl_member WHERE login = '" & parse(login) & "' and password ='" & parse(password) & "'"
rslogin.CursorType = 0
rslogin.CursorLocation = 2
rslogin.LockType = 1
rslogin.Open()
if rslogin.eof then
pusherror "Invalid login id or password."
else
session("memberid") = rslogin("memberid")
session("login") = rslogin("login")
session("firstname") = rslogin("firstname")
session("longmemberid") = rslogin("longmemberid")
if chk <> "" then
response.redirect("shoppingcart.asp?chk=1")
else
response.Redirect("myaccount.asp")
end if
end if
end if
sub pusherror(str)
if error_msg = "" then
error_msg = "• " & str
else
error_msg = error_msg & " " & "• " & str
end if
end sub
%>
Member Login
SIGN-UP
<%
'1. function parse (str) : parse all incoming submissions
'2. function unparse (str) : opposite of parse
'3. function record_exists( tbl_name, column_name, the_value)
' : checks for duplicate record based on 1 primary column -- used in adding records
'4. function record_exists_ext( tbl_name, column_name_1, column_name_2, the_value_1, the_value_2)
' : checks for duplicate record based on 2 columns -- used in updating records
'5. function insert_command(tbl_name, arr_cols, arr_values)
' : constructs an insert command
' : makes insertions of quotes and commas a breeze
'6. function update_command(tbl_name, idcol, idval, arr_cols, arr_values)
' : constructs and edit command
' : makes insertions of quotes and commas a breeze
%>
<%
function parse (str)
parse = trim(replace(replace(str, "'", "''"), "|", ""))
end function
function unparse (str)
if str <> "" then
unparse = trim(replace(str, "''", "'"))
else
unparse = ""
end if
end function
function record_exists( tbl_name, column_name, the_value, isInteger)
Dim quote
quote = "'"
if isInteger=1 then quote = ""
Set rs = Server.CreateObject("ADODB.Recordset")
rs.ActiveConnection = MM_Connection_STRING
rs.Source = "SELECT * FROM " & tbl_name & " WHERE " & column_name & " = " & quote & the_value & quote
'response.write rs.Source
'response.End()
rs.CursorType = 0
rs.CursorLocation = 2
rs.LockType = 1
rs.Open()
if rs.eof then
record_exists = false
else
record_exists = true
end if
rs.Close()
Set rs = Nothing
end function
function record_exists_ext( tbl_name, column_name_1, column_name_2, the_value_1, value_1_isInt, the_value_2, value_2_isInt)
Dim quote1
Dim quote2
quote1 = "'"
quote2 = "'"
if value_1_isInt = 1 then quote1 = ""
if value_2_isInt = 1 then quote2 = ""
Set rs = Server.CreateObject("ADODB.Recordset")
rs.ActiveConnection = MM_Connection_STRING
rs.Source = "SELECT * FROM " & tbl_name & " WHERE " & column_name_1 & " = " & quote1 & the_value_1 & quote1 & " AND " & column_name_2 & " = " & quote2 & the_value_2 & quote2
' response.write rs.Source
' response.end()
rs.CursorType = 0
rs.CursorLocation = 2
rs.LockType = 1
rs.Open()
if rs.eof then
record_exists_ext = false
else
record_exists_ext = true
end if
rs.Close()
Set rs = Nothing
end function
function record_exists_edit_level_1( tbl_name, column_name_1, column_name_2, the_value_1, value_1_isInt, the_value_2, value_2_isInt)
Dim quote1
Dim quote2
quote1 = "'"
quote2 = "'"
if value_1_isInt = 1 then quote1 = ""
if value_2_isInt = 1 then quote2 = ""
Set rs = Server.CreateObject("ADODB.Recordset")
rs.ActiveConnection = MM_Connection_STRING
rs.Source = "SELECT * FROM " & tbl_name & " WHERE " & column_name_1 & " = " & quote1 & the_value_1 & quote1 & " AND " & column_name_2 & " <> " & quote2 & the_value_2 & quote2
' response.write rs.Source
' response.end()
rs.CursorType = 0
rs.CursorLocation = 2
rs.LockType = 1
rs.Open()
if rs.eof then
record_exists_edit_level_1 = false
else
record_exists_edit_level_1 = true
end if
rs.Close()
Set rs = Nothing
end function
function record_exists_edit_level_2( tbl_name, column_name_1, column_name_2, column_name_3, the_value_1, value_1_isInt, the_value_2, value_2_isInt, the_value_3, value_3_isInt)
Dim quote1
Dim quote2
quote1 = "'"
quote2 = "'"
quote3 = "'"
if value_1_isInt = 1 then quote1 = ""
if value_2_isInt = 1 then quote2 = ""
if value_3_isInt = 1 then quote3 = ""
Set rs = Server.CreateObject("ADODB.Recordset")
rs.ActiveConnection = MM_Connection_STRING
rs.Source = "SELECT * FROM " & tbl_name & " WHERE " & column_name_1 & " = " & quote1 & the_value_1 & quote1 & " AND " & column_name_2 & " <> " & quote2 & the_value_2 & quote2 & " AND " & column_name_3 & " = " & quote3 & the_value_3 & quote3
' response.write rs.Source
' response.end()
rs.CursorType = 0
rs.CursorLocation = 2
rs.LockType = 1
rs.Open()
if rs.eof then
record_exists_edit_level_2 = false
else
record_exists_edit_level_2 = true
end if
rs.Close()
Set rs = Nothing
end function
function insert_command(tbl_name, arr_cols, arr_values)
dim i
cols = split(arr_cols, "|")
vals = split(arr_values, "|")
ub_arr = ubound(cols)
str = "INSERT INTO " & tbl_name & "("
scol = ""
sval = ""
for i = 0 to ub_arr
if i < ub_arr then
scol = scol & cols(i) & ","
sval = sval & "'" & vals(i) & "',"
else
scol = scol & cols(i)
sval = sval & "'" & vals(i) & "'"
end if
next
str = str & scol & ") VALUES (" & sval & ")"
insert_command = str
end function
function update_command(tbl_name, idcol, idcol_isInt, idval, arr_cols, arr_values)
dim i
if idcol_isInt = 1 then
quote1 = ""
else
quote1 = "'"
end if
cols = split(arr_cols, "|")
vals = split(arr_values, "|")
ub_arr = ubound(cols)
str = "UPDATE " & tbl_name & " SET "
s = ""
for i = 0 to ub_arr
if i < ub_arr then
s = s & cols(i) & "='" & vals(i) & "',"
else
s = s & cols(i) & "='" & vals(i) & "'"
end if
next
str = str & s & " WHERE " & idcol & "=" & quote1 & idval & quote1
update_command = str
end function
function update_all_command(tbl_name, arr_cols, arr_values)
dim i
cols = split(arr_cols, "|")
vals = split(arr_values, "|")
ub_arr = ubound(cols)
str = "UPDATE " & tbl_name & " SET "
s = ""
for i = 0 to ub_arr
if i < ub_arr then
s = s & cols(i) & "='" & vals(i) & "',"
else
s = s & cols(i) & "='" & vals(i) & "'"
end if
next
str = str & s & " "
update_all_command = str
end function
function delete_command(tbl_name, idcol, idval )
if isnumeric(idval) then
str = "DELETE FROM " & tbl_name & " WHERE " & idcol & "=" & idval
else
str = "DELETE FROM " & tbl_name & " WHERE " & idcol & "='" & idval & "'"
end if
delete_command = str
end function
Function IsValidEmail(sText)
'validate email address
Dim i
Dim iTmpChar
Dim sDomainExt
Dim vEmail
Dim vDomain
IsValidEmail = False
'check for 1 @ symbol
vEmail = Split(sText, "@")
If UBound(vEmail) <> 1 Then Exit Function
If vEmail(0) = "" Or vEmail(1) = "" Then Exit Function
'validate account
For i = 1 To Len(vEmail(0))
'check for valid characters
iTmpChar = Asc(Mid(LCase(vEmail(0)), i, 1))
'test for letters
If Not (iTmpChar >= Asc("a")) And (iTmpChar <= Asc("z")) Then
'test for numbers
If Not IsNumeric(Chr(iTmpChar)) Then
'test for exceptions
If Chr(iTmpChar) <> "." And Chr(iTmpChar) <> "_" And Chr(iTmpChar) <> "-" Then Exit Function
End If
End If
Next
'validate domain
For i = 1 To Len(vEmail(1))
'check for valid characters
iTmpChar = Asc(Mid(LCase(vEmail(1)), i, 1))
'test for letters
If Not (iTmpChar >= Asc("a")) And (iTmpChar <= Asc("z")) Then
'test for numbers
If Not IsNumeric(Chr(iTmpChar)) Then
'test for exceptions
If Chr(iTmpChar) <> "." And Chr(iTmpChar) <> "-" Then Exit Function
End If
End If
Next
'validate domain extension
vDomain = Split(vEmail(1), ".")
sDomainExt = vDomain(UBound(vDomain))
If Len(sDomainExt) < 2 Or Len(sDomainExt) > 4 Then Exit Function
'test for letters
For i = 1 To Len(sDomainExt)
iTmpChar = Asc(Mid(LCase(sDomainExt), i, 1))
If Not (iTmpChar >= Asc("a")) And (iTmpChar <= Asc("z")) Then Exit Function
Next
IsValidEmail = True
End Function
%>
<%
dim subs_error_msg
subscribe = trim(request("subscribe"))
if subscribe <> "" then
name = trim(request("name"))
email = trim(request("email"))
if name = "" then subs_push_error "Please enter your name."
if NOT IsValidEmail(email) then subs_push_error "Please enter a valid email address."
if record_exists( "tbl_subscriber", "email", email, 0) then subs_push_error "This email address is already subscribed."
if subs_error_msg <> "" then
subs_error_msg = "" & subs_error_msg & "
"
else
Set rsSubs = Server.CreateObject("ADODB.Recordset")
rsSubs.ActiveConnection = MM_connection_STRING
rsSubs.Source = "insert into tbl_subscriber(name,email) values ('" & name & "', '" & email & "')"
rsSubs.CursorType = 0
rsSubs.CursorLocation = 2
rsSubs.LockType = 1
rsSubs.Open()
rsSubs.Source = "SELECT max(subscriber_id) as id FROM tbl_subscriber"
rsSubs.Open()
id = rsSubs("id")
rsSubs.Close
set rsSubs = Nothing
name = ""
email = ""
response.Redirect("subsribed_confirm.asp?id=" & id )
response.End()
end if
end if
%>
<%
sub subs_push_error (str)
if subs_error_msg = "" then
subs_error_msg = "* " & str
else
subs_error_msg = subs_error_msg & " * " & str
end if
end sub
%>
THE FITCALL
Introducing the NEW Fitcall:
Do The Sleeping Beauty Workout from the comfort of your own home!
