<%
' ASPMaker 5 configuration
' Project Level Constants
Const ewProjectName = "webshop0307" ' Project Name
Const ewSessionStatus = "webshop0307_status" ' Login Status
Const ewSessionUserName = "webshop0307_status_UserName" ' User Name
Const ewSessionUserID = "webshop0307_status_UserID" ' User ID
Const ewSessionUserLevel = "webshop0307_status_UserLevel" ' User Level
Const ewSessionParentUserID = "webshop0307_status_ParentUserID" ' Parent User ID
Const ewSessionSysAdmin = "webshop0307_SysAdmin" ' System Admin
Const ewSessionArUserLevel = "webshop0307_arUserLevel" ' User Level Array
Const ewSessionArUserLevelPriv = "webshop0307_arUserLevelPriv" ' User Level Privilege Array
Const ewSessionSecurity = "webshop0307_Security" ' Security Array
Const ewSessionMessage = "webshop0307_Message" ' System Message
%>
<%
xDb_Conn_Str = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Request.ServerVariables("APPL_PHYSICAL_PATH") & "\_data\sitedata01.mdb" & ";"
' Function to Adjust SQL
Function AdjustSql(str)
Dim sWrk
sWrk = Trim(str & "")
sWrk = Replace(sWrk, "'", "''") ' Adjust for Single Quote
sWrk = Replace(sWrk, "[", "[[]") ' Adjust for Open Square Bracket
AdjustSql = sWrk
End Function
' Function to Build SQL
Function ewBuildSql(sSelect, sWhere, sGroupBy, sHaving, sOrderBy, sFilter, sSort)
Dim sSql, sDbWhere, sDbOrderBy
sDbWhere = sWhere
If sDbWhere <> "" Then
sDbWhere = "(" & sDbWhere & ")"
End If
If sFilter <> "" Then
If sDbWhere <> "" Then sDbWhere = sDbWhere & " AND "
sDbWhere = sDbWhere & "(" & sFilter & ")"
End If
sDbOrderBy = sOrderBy
If sSort <> "" Then
sDbOrderBy = sSort
End If
sSql = sSelect
If sDbWhere <> "" Then
sSql = sSql & " WHERE " & sDbWhere
End If
If sGroupBy <> "" Then
sSql = sSql & " GROUP BY " & sGroupBy
End If
If sHaving <> "" Then
sSql = sSql & " HAVING " & sHaving
End If
If sDbOrderBy <> "" Then
sSql = sSql & " ORDER BY " & sDbOrderBy
End If
ewBuildSql = sSql
End Function
%>
<%
' ASPMaker 5 configuration
' Table Level Constants
Const ewTblVar = "contact"
Const ewTblRecPerPage = "RecPerPage"
Const ewSessionTblRecPerPage = "contact_RecPerPage"
Const ewTblStartRec = "start"
Const ewSessionTblStartRec = "contact_start"
Const ewTblShowMaster = "showmaster"
Const ewSessionTblMasterKey = "contact_MasterKey"
Const ewSessionTblMasterWhere = "contact_MasterWhere"
Const ewSessionTblDetailWhere = "contact_DetailWhere"
Const ewSessionTblAdvSrch = "contact_AdvSrch"
Const ewTblBasicSrch = "psearch"
Const ewSessionTblBasicSrch = "contact_psearch"
Const ewTblBasicSrchType = "psearchtype"
Const ewSessionTblBasicSrchType = "contact_psearchtype"
Const ewSessionTblSearchWhere = "contact_SearchWhere"
Const ewSessionTblSort = "contact_Sort"
Const ewSessionTblOrderBy = "contact_OrderBy"
Const ewSessionTblKey = "contact_Key"
' Table Level SQL
Const ewSqlSelect = "SELECT * FROM [contact]"
Const ewSqlWhere = ""
Const ewSqlGroupBy = ""
Const ewSqlHaving = ""
Const ewSqlOrderBy = ""
Const ewSqlOrderBySessions = ""
Const ewSqlKeyWhere = "[ID] = @ID"
Const ewSqlUserIDFilter = ""
%>
<%
' Advanced User Level Security for ASPMaker 5+
Const ewAllowAdd = 1
Const ewAllowDelete = 2
Const ewAllowEdit = 4
Const ewAllowView = 8
Const ewAllowList = 8
Const ewAllowReport = 8
Const ewAllowSearch = 8
Const ewAllowAdmin = 16
Dim arUserLevel ' User Level definitions
Dim arUserLevelPriv ' User Level privileges
' Define User Level Variables
Dim ewCurLvl ' Current user level
ewCurLvl = CurrentUserLevel()
Dim ewCurSec
' No user level security
Sub SetUpUserLevel
End Sub
' Get current user privilege
Function CurrentUserLevelPriv(TableName)
CurrentUserLevelPriv = GetUserLevelPrivEx(TableName, CurrentUserLevel)
End Function
' Get anonymous user privilege
Function GetAnonymousPriv(TableName)
GetAnonymousPriv = GetUserLevelPrivEx(TableName, 0)
End Function
' Get user privilege based on table name and user level
Function GetUserLevelPrivEx(TableName, UserLevel)
GetUserLevelPrivEx = 0
If CStr(UserLevel) = "-1" Then ' System Administrator
GetUserLevelPrivEx = 31
ElseIf UserLevel >= 0 Then
If IsArray(arUserLevelPriv) Then
Dim I
For I = 0 to UBound(arUserLevelPriv, 2)
If CStr(arUserLevelPriv(0, I)) = CStr(TableName) And _
CStr(arUserLevelPriv(1, I)) = CStr(UserLevel) Then
GetUserLevelPrivEx = arUserLevelPriv(2, I)
If IsNull(GetUserLevelPrivEx) Then GetUserLevelPrivEx = 0
If Not IsNumeric(GetUserLevelPrivEx) Then GetUserLevelPrivEx = 0
GetUserLevelPrivEx = CLng(GetUserLevelPrivEx)
Exit For
End If
Next
End If
End If
End Function
' Get current user level name
Function CurrentUserLevelName
GetUserLevelName(CurrentUserLevel)
End Function
' Get user level name based on user level
Function GetUserLevelName(UserLevel)
GetUserLevelName = ""
If CStr(UserLevel) = "-1" Then
GetUserLevelName = "Administrator"
ElseIf UserLevel >= 0 Then
If IsArray(arUserLevel) Then
Dim I
For I = 0 to UBound(arUserLevel, 2)
If CStr(arUserLevel(0, I)) = CStr(UserLevel) Then
GetUserLevelName = arUserLevel(1, I)
Exit For
End If
Next
End If
End If
End Function
' Sub to display all the User Level settings (for debug only)
Sub ShowUserLevelInfo
Dim I
If IsArray(arUserLevel) Then
Response.Write "User Levels:
"
Response.Write "UserLevelId, UserLevelName
"
For I = 0 To UBound(arUserLevel, 2)
Response.Write " " & arUserLevel(0, I) & ", " & _
arUserLevel(1, I) & "
"
Next
Else
Response.Write "No User Level definitions." & "
"
End If
If IsArray(arUserLevelPriv) Then
Response.Write "User Level Privs:
"
Response.Write "TableName, UserLevelId, UserLevelPriv
"
For I = 0 To UBound(arUserLevelPriv, 2)
Response.Write " " & arUserLevelPriv(0, I) & ", " & _
arUserLevelPriv(1, I) & ", " & arUserLevelPriv(2, I) & "
"
Next
Else
Response.Write "No User Level privilege settings." & "
"
End If
Response.Write "CurrentUserLevel = " & CurrentUserLevel & "
"
End Sub
' Function to check privilege for List page (for menu items)
Function AllowList(TableName)
AllowList = CBool(CurrentUserLevelPriv(TableName) And ewAllowList)
End Function
' Get current user name from session
Function CurrentUserName
CurrentUserName = Session(ewSessionUserName) & ""
End Function
' Get current user id from session
Function CurrentUserID
CurrentUserID = Session(ewSessionUserID) & ""
End Function
' Get current parent user id from session
Function CurrentParentUserID
CurrentParentUserID = Session(ewSessionParentUserID) & ""
End Function
' Get current user level from session
Function CurrentUserLevel
If IsLoggedIn Then
CurrentUserLevel = Session(ewSessionUserLevel)
Else
CurrentUserLevel = 0 ' Anonymous if not logged in
End If
End Function
' Check if user is logged in
Function IsLoggedIn
IsLoggedIn = (Session(ewSessionStatus) = "login")
End Function
' Check if user is system administrator
Function IsSysAdmin
IsSysAdmin = (Session(ewSessionSysAdmin) = 1)
End Function
' Save user level to session
Sub SaveUserLevel
Session(ewSessionArUserLevel) = arUserLevel
Session(ewSessionArUserLevelPriv) = arUserLevelPriv
End Sub
' Load user level from session
Sub LoadUserLevel
If Not IsArray(Session(ewSessionArUserLevel)) Then
SetupUserLevel
SaveUserLevel
End If
arUserLevel = Session(ewSessionArUserLevel)
arUserLevelPriv = Session(ewSessionArUserLevelPriv)
End Sub
%>
<%
' ASPMaker functions for ASPMaker 5+
' (C)2006 e.World Technology Ltd.
' Common constants
Const EW_DATE_SEPARATOR = "/"
Const EW_SMTPSERVER = "fieldhousefitness.net"
Const EW_SMTPSERVER_PORT = 25
Const EW_SMTPSERVER_USERNAME = "fieldhousefitness.net"
Const EW_SMTPSERVER_PASSWORD = ""
'-------------------------------------------------------------------------------
' Functions for default date format
' ANamedFormat = 0-8, where 0-4 same as VBScript
' 5 = "yyyy/mm/dd"
' 6 = "mm/dd/yyyy"
' 7 = "dd/mm/yyyy"
' 8 = Short Date & " " & Short Time
Function EW_FormatDateTime(ADate, ANamedFormat)
If IsDate(ADate) Then
If ANamedFormat >= 0 And ANamedFormat <= 4 Then
EW_FormatDateTime = FormatDateTime(ADate, ANamedFormat)
ElseIf ANamedFormat = 5 Then
EW_FormatDateTime = Year(ADate) & EW_DATE_SEPARATOR & Month(ADate) & EW_DATE_SEPARATOR & Day(ADate)
ElseIf ANamedFormat = 6 Then
EW_FormatDateTime = Month(ADate) & EW_DATE_SEPARATOR & Day(ADate) & EW_DATE_SEPARATOR & Year(ADate)
ElseIf ANamedFormat = 7 Then
EW_FormatDateTime = Day(ADate) & EW_DATE_SEPARATOR & Month(ADate) & EW_DATE_SEPARATOR & Year(ADate)
ElseIf ANamedFormat = 8 Then
EW_FormatDateTime = FormatDateTime(ADate, 2)
If Hour(ADate) <> 0 Or Minute(ADate) <> 0 Or Second(ADate) <> 0 Then
EW_FormatDateTime = EW_FormatDateTime & " " & FormatDateTime(ADate, 4) & ":" & ewZeroPad(Second(ADate), 2)
End If
Else
EW_FormatDateTime = ADate
End If
Else
EW_FormatDateTime = ADate
End If
End Function
Function EW_UnFormatDateTime(ADate, ANamedFormat)
Dim arDateTime, arDate
ADate = Trim(ADate & "")
While Instr(ADate, " ") > 0
ADate = Replace(ADate, " ", " ")
Wend
arDateTime = Split(ADate, " ")
If UBound(arDateTime) < 0 Then
EW_UnFormatDateTime = ADate
Exit Function
End If
arDate = Split(arDateTime(0), EW_DATE_SEPARATOR)
If UBound(arDate) = 2 Then
If ANamedFormat = 6 Then
EW_UnFormatDateTime = arDate(2) & "/" & arDate(0) & "/" & arDate(1)
ElseIf ANamedFormat = 7 Then
EW_UnFormatDateTime = arDate(2) & "/" & arDate(1) & "/" & arDate(0)
ElseIf ANamedFormat = 5 Then
EW_UnFormatDateTime = arDate(0) & "/" & arDate(1) & "/" & arDate(2)
Else
EW_UnFormatDateTime = arDateTime(0)
End If
If UBound(arDateTime) > 0 Then
If IsDate(arDateTime(1)) Then ' Is time
EW_UnFormatDateTime = EW_UnFormatDateTime & " " & arDateTime(1)
End If
End If
Else
EW_UnFormatDateTime = ADate
End If
End Function
'-------------------------------------------------------------------------------
' Function for format percent
Function EW_FormatPercent(Expression, NumDigitsAfterDecimal, IncludeLeadingDigit, UseParensForNegativeNumbers, GroupDigits)
On Error Resume Next
EW_FormatPercent = FormatPercent(Expression, NumDigitsAfterDecimal, IncludeLeadingDigit, UseParensForNegativeNumbers, GroupDigits)
If Err.Number <> 0 Then
EW_FormatPercent = FormatNumber(Expression*100, NumDigitsAfterDecimal, IncludeLeadingDigit, UseParensForNegativeNumbers, GroupDigits) & "%"
End If
End Function
' Note: Object "conn" is required
Function ewExecuteScalar(SQL)
ewExecuteScalar = Null
If Trim(SQL&"") = "" Then Exit Function
Dim rs
Set rs = conn.Execute(SQL)
If Not rs.Eof Then ewExecuteScalar = rs(0)
rs.Close
Set rs = Nothing
End Function
'-------------------------------------------------------------------------------
' Function for debug
Sub Trace(aMsg)
On Error Resume Next
Dim fso, ts
Set fso = Server.Createobject("Scripting.FileSystemObject")
Set ts = fso.OpenTextFile(Server.MapPath("debug.txt"), 8, True)
ts.writeline(aMsg)
ts.Close
Set ts = Nothing
Set fso = Nothing
End Sub
%>
<%
' Function to Load Email Content from input file name
' - Content Loaded to the following variables
' - Subject: sEmailSubject
' - From: sEmailFrom
' - To: sEmailTo
' - Cc: sEmailCc
' - Bcc: sEmailBcc
' - Format: sEmailFormat
' - Content: sEmailContent
'
sEmailFrom = "": sEmailTo = "": sEmailCc = "": sEmailBcc = "": sEmailSubject = "": sEmailFormat = "": sEmailContent = ""
Sub LoadEmail(fn)
Dim sWrk, sHeader, arrHeader
Dim sName, sValue
Dim i, j
' Initialize
sEmailFrom = "": sEmailTo = "": sEmailCc = "": sEmailBcc = "": sEmailSubject = "": sEmailFormat = "": sEmailContent = ""
sWrk = LoadTxt(fn) ' Load text file content
sWrk = Replace(sWrk, vbCrLf, vbLf) ' Convert to Lf
sWrk = Replace(sWrk, vbCr, vbLf) ' Convert to Lf
If sWrk <> "" Then
' Locate Header & Mail Content
i = InStr(sWrk, vbLf&vbLf)
If i > 0 Then
sHeader = Mid(sWrk, 1, i)
sEmailContent = Mid(sWrk, i+2)
arrHeader = Split(sHeader, vbLf)
For j = 0 to UBound(arrHeader)
i = InStr(arrHeader(j), ":")
If i > 0 Then
sName = Trim(Mid(arrHeader(j), 1, i-1))
sValue = Trim(Mid(arrHeader(j), i+1))
Select Case LCase(sName)
Case "subject": sEmailSubject = sValue
Case "from": sEmailFrom = sValue
Case "to": sEmailTo = sValue
Case "cc": sEmailCc = sValue
Case "bcc": sEmailBcc = sValue
Case "format": sEmailFormat = sValue
End Select
End If
Next
End If
End If
End Sub
' Function to Load a Text File
Function LoadTxt(fn)
Dim fso, fobj
' Get text file content
Set fso = Server.CreateObject("Scripting.FileSystemObject")
Set fobj = fso.OpenTextFile(Server.MapPath(fn))
LoadTxt = fobj.ReadAll ' Read all Content
fobj.Close
Set fobj = Nothing
End Function
' Function to Send out Email
Sub Send_Email(sFrEmail, sToEmail, sCcEmail, sBccEmail, sSubject, sMail, sFormat)
Dim objMail, objConfig, sServerVersion, i, sIISVer
Dim sSmtpServer, iSmtpServerPort
sServerVersion = Request.ServerVariables("SERVER_SOFTWARE")
If InStr(sServerVersion, "Microsoft-IIS") > 0 Then
i = InStr(sServerVersion, "/")
If i > 0 Then
sIISVer = Trim(Mid(sServerVersion, i+1))
End If
End If
If sIISVer < "5.0" Then
' NT using CDONTS
Set objMail = Server.CreateObject("CDONTS.NewMail")
objMail.From = sFrEmail
objMail.To = Replace(sToEmail, ",", ";")
If sCcEmail <> "" Then
objMail.Cc = Replace(sCcEmail, ",", ";")
End If
If sBccEmail <> "" Then
objMail.Bcc = Replace(sBccEmail, ",", ";")
End If
If LCase(sFormat) = "html" Then
objMail.BodyFormat = 0 ' 0 means HTML format, 1 means text
objMail.MailFormat = 0 ' 0 means MIME, 1 means text
End If
objMail.Subject = sSubject
objMail.Body = sMail
objMail.Send
Set objMail = Nothing
Else
' 2000 / XP / 2003 using CDO
' Set up Configuration
Set objConfig = Server.CreateObject("CDO.Configuration")
objConfig.Fields("http://schemas.microsoft.com/cdo/configuration/smtpserver") = EW_SMTPSERVER ' cdoSMTPServer
objConfig.Fields("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = EW_SMTPSERVER_PORT ' cdoSMTPServerPort
objConfig.Fields("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
If EW_SMTPSERVER_USERNAME <> "" And EW_SMTPSERVER_PASSWORD <> "" Then
objConfig.Fields("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1 'cdoBasic (clear text)
objConfig.Fields("http://schemas.microsoft.com/cdo/configuration/sendusername") = EW_SMTPSERVER_USERNAME
objConfig.Fields("http://schemas.microsoft.com/cdo/configuration/sendpassword") = EW_SMTPSERVER_PASSWORD
End If
objConfig.Fields.Update
' Set up Mail
Set objMail = Server.CreateObject("CDO.Message")
objMail.From = sFrEmail
objMail.To = Replace(sToEmail, ",", ";")
If sCcEmail <> "" Then
objMail.Cc = Replace(sCcEmail, ",", ";")
End If
If sBccEmail <> "" Then
objMail.Bcc = Replace(sBccEmail, ",", ";")
End If
If LCase(sFormat) = "html" Then
objMail.HtmlBody = sMail
Else
objMail.TextBody = sMail
End If
objMail.Subject = sSubject
If EW_SMTPSERVER <> "" And LCase(EW_SMTPSERVER) <> "localhost" Then
Set objMail.Configuration = objConfig ' Use Configuration
objMail.Send
Else
On Error Resume Next
objMail.Send ' Send without Configuration
If Err.Number <> 0 Then
If Hex(Err.Number) = "80040220" Then ' Requires Configuration
Set objMail.Configuration = objConfig
Err.Clear
On Error GoTo 0
objMail.Send
Else
Dim ErrNo, ErrSrc, ErrDesc
ErrNo = Err.Number
ErrSrc = Err.Source
ErrDesc = Err.Description
On Error GoTo 0
Err.Raise ErrNo, ErrSrc, ErrDesc
End If
End If
End If
Set objMail = Nothing
Set objConfig = Nothing
End If
End Sub
%>
<%
' Function to generate Value Separator based on current row count
' rowcnt - zero based row count
'
Function ValueSeparator(rowcnt)
ValueSeparator = ", "
End Function
' Function to generate View Option Separator based on current row count (Multi-Select / CheckBox)
' rowcnt - zero based row count
'
Function ViewOptionSeparator(rowcnt)
ViewOptionSeparator = ", "
' Sample code to adjust 2 options per row
'If ((rowcnt + 1) Mod 2 = 0) Then ' 2 options per row
'ViewOptionSeparator = ViewOptionSeparator & "
"
'End If
End Function
' Function to render repeat column table
' rowcnt - zero based row count
'
Function RenderControl(totcnt, rowcnt, repeatcnt, rendertype)
Dim sWrk
sWrk = ""
' Render control start
If rendertype = 1 Then
If rowcnt = 0 Then sWrk = sWrk & ""
If (rowcnt mod repeatcnt = 0) Then sWrk = sWrk & ""
sWrk = sWrk & "| "
' Render control end
ElseIf rendertype = 2 Then
sWrk = sWrk & " | "
If (rowcnt mod repeatcnt = repeatcnt -1) Then
sWrk = sWrk & " "
ElseIf rowcnt = totcnt Then
For i = ((rowcnt mod repeatcnt) + 1) to repeatcnt - 1
sWrk = sWrk & " | "
Next
sWrk = sWrk & ""
End If
If rowcnt = totcnt Then sWrk = sWrk & " "
End If
RenderControl = sWrk
End Function
' Function to truncate Memo Field based on specified length, string truncated to nearest space or CrLf
'
Function TruncateMemo(str, ln)
Dim i, j, k
If Len(str) > 0 And Len(str) > ln Then
k = 1
Do While k > 0 And k < Len(str)
i = InStr(k, str, " ", 1)
j = InStr(k, str, vbCrLf, 1)
If i < 0 And j < 0 Then ' Not able to truncate
TruncateMemo = str
Exit Function
Else
' Get nearest space or CrLf
If i > 0 And j > 0 Then
If i < j Then
k = i
Else
k = j
End If
ElseIf i > 0 Then
k = i
ElseIf j > 0 Then
k = j
End If
' Get truncated text
If k >= ln Then
TruncateMemo = Mid(str, 1, k-1) & "..."
Exit Function
Else
k = k + 1
End If
End If
Loop
Else
TruncateMemo = str
End If
End Function
%>
<%
Function CloneRs(Rs)
Dim oStream
Dim oRsClone
' Save the recordset to the stream object
Set oStream = Server.CreateObject("ADODB.Stream")
Rs.Save oStream
' Open the stream object into a new recordset
Set oRsClone = Server.CreateObject("ADODB.Recordset")
oRsClone.Open oStream, , , 2
' Return the cloned recordset
Set CloneRs = oRsClone
' Release the reference
Set oRsClone = Nothing
End Function
'-------------------------------------------------------------------------------
' Function for Writing audit trail
'
Sub ewWriteAuditTrail(pfx, curDate, curTime, id, user, action, table, field, keyvalue, oldvalue, newvalue)
On Error Resume Next
Dim fso, ts, sMsg, sFn, sFolder
Dim bWriteHeader, sHeader
Dim userwrk
userwrk = user
If userwrk = "" Then userwrk = "-1" ' assume Administrator if no user
sHeader = "date" & vbTab & _
"time" & vbTab & _
"id" & vbTab & _
"user" & vbTab & _
"action" & vbTab & _
"table" & vbTab & _
"field" & vbTab & _
"key value" & vbTab & _
"old value" & vbTab & _
"new value"
sMsg = curDate & vbTab & _
curTime & vbTab & _
id & vbTab & _
userwrk & vbTab & _
action & vbTab & _
table & vbTab & _
field & vbTab & _
keyvalue & vbTab & _
oldvalue & vbTab & _
newvalue
sFolder = ""
sFn = pfx & "_" & ewZeroPad(Year(Date), 4) & ewZeroPad(Month(Date), 2) & ewZeroPad(Day(Date), 2) & ".txt"
Set fso = Server.Createobject("Scripting.FileSystemObject")
bWriteHeader = Not fso.FileExists(Server.MapPath(sFolder & sFn))
Set ts = fso.OpenTextFile(Server.MapPath(sFolder & sFn), 8, True)
If bWriteHeader Then
ts.writeline(sHeader)
End If
ts.writeline(sMsg)
ts.Close
Set ts = Nothing
Set fso = Nothing
End Sub
' Pad zeros before number
Function ewZeroPad(m, t)
ewZeroPad = String(t - Len(m), "0") & m
End Function
' IIf function
Function ewIIf(cond, v1, v2)
On Error Resume Next
If CBool(cond) Then
ewIIf = v1
Else
ewIIf = v2
End If
End Function
' Convert different data type value
Function ewConv(v, t)
Select Case t
' adBigInt/adUnsignedBigInt
Case 20, 21
If IsNull(v) Then
ewConv = Null
Else
ewConv = CLng(v)
End If
' adSmallInt/adInteger/adTinyInt/adUnsignedTinyInt/adUnsignedSmallInt/adUnsignedInt/adBinary
Case 2, 3, 16, 17, 18, 19, 128
If IsNull(v) Then
ewConv = Null
Else
ewConv = CLng(v)
End If
' adSingle
Case 4
If IsNull(v) Then
ewConv = Null
Else
ewConv = CSng(v)
End If
' adDouble/adCurrency/adNumeric
Case 5, 6, 131
If IsNull(v) Then
ewConv = Null
Else
ewConv = CDbl(v)
End If
Case Else
ewConv = v
End Select
End Function
%>
<%
' File upload functions for ASPMaker 5+
' (C) 2006 e.World Technology Ltd.
' Config for file upload
Const EW_UploadDestPath = "" ' upload destination path
Const EW_UploadAllowedFileExt = "gif,jpg,jpeg,bmp,png,doc,xls,pdf,zip" ' allowed file extensions
Const EW_UploadCharset = ""
' Function to return path of the uploaded file
' Parameter: If PhyPath is true(1), return physical path on the server;
' If PhyPath is false(0), return relative URL
Function ewUploadPathEx(PhyPath, DestPath)
Dim Pos
If PhyPath Then
ewUploadPathEx = Request.ServerVariables("APPL_PHYSICAL_PATH")
ewUploadPathEx = ewIncludeTrailingDelimiter(ewUploadPathEx, PhyPath)
ewUploadPathEx = ewUploadPathEx & Replace(DestPath, "/", "\")
Else
ewUploadPathEx = Request.ServerVariables("APPL_MD_PATH")
Pos = InStr(1, ewUploadPathEx, "Root", 1)
If Pos > 0 Then ewUploadPathEx = Mid(ewUploadPathEx, Pos+4)
ewUploadPathEx = ewIncludeTrailingDelimiter(ewUploadPathEx, PhyPath)
ewUploadPathEx = ewUploadPathEx & DestPath
End If
ewUploadPathEx = ewIncludeTrailingDelimiter(ewUploadPathEx, PhyPath)
End Function
' Function to change the file name of the uploaded file
Function ewUploadFileNameEx(Folder, FileName)
Dim OutFileName
' By default, ewUniqueFileName() is used to get an unique file name.
' Amend your logic here
OutFileName = ewUniqueFileName(Folder, FileName)
' Return computed output file name
ewUploadFileNameEx = OutFileName
End Function
' Function to return path of the uploaded file
' returns global upload folder, for backward compatibility only
Function ewUploadPath(PhyPath)
ewUploadPath = ewUploadPathEx(PhyPath, EW_UploadDestPath)
End Function
' Function to change the file name of the uploaded file
' use global upload folder, for backward compatibility only
Function ewUploadFileName(FileName)
ewUploadFileName = ewUploadFileNameEx(ewUploadPath(True), FileName)
End Function
' Function to generate an unique file name (filename(n).ext)
Function ewUniqueFileName(Folder, FileName)
If FileName = "" Then FileName = ewDefaultFileName()
If FileName = "." Then
Response.Write "Invalid file name: " & FileName
Response.End
Exit Function
End If
If Folder = "" Then
Response.Write "Unspecified folder"
Response.End
Exit Function
End If
Dim Name, Ext, Pos
Name = ""
Ext = ""
Pos = InStrRev(FileName, ".")
If Pos = 0 Then
Name = FileName
Ext = ""
Else
Name = Mid(FileName, 1, Pos-1)
Ext = Mid(FileName, Pos+1)
End If
Folder = ewIncludeTrailingDelimiter(Folder, True)
Dim fso
Set fso = Server.CreateObject("Scripting.FileSystemObject")
If Not fso.FolderExists(Folder) Then
If Not ewCreateFolder(Folder) Then
Response.Write "Folder does not exist: " & Folder
Set fso = Nothing
Exit Function
End If
End If
Dim Suffix, Index
Index = 0
Suffix = ""
' Check to see if filename exists
While fso.FileExists(folder & Name & Suffix & "." & Ext)
Index = Index + 1
Suffix = "(" & Index & ")"
Wend
Set fso = Nothing
' Return unique file name
ewUniqueFileName = Name & Suffix & "." & Ext
End Function
' Function to create a default file name (yyyymmddhhmmss.bin)
Function ewDefaultFileName
Dim DT
DT = Now()
ewDefaultFileName = ewZeroPad(Year(DT), 4) & ewZeroPad(Month(DT), 2) & _
ewZeroPad(Day(DT), 2) & ewZeroPad(Hour(DT), 2) & _
ewZeroPad(Minute(DT), 2) & ewZeroPad(Second(DT), 2) & ".bin"
End Function
' Function to check the file type of the uploaded file
Function ewUploadAllowedFileExt(FileName)
If Trim(FileName & "") = "" Then
ewUploadAllowedFileExt = True
Exit Function
End If
Dim Ext, Pos, arExt, FileExt
arExt = Split(EW_UploadAllowedFileExt & "", ",")
Ext = ""
Pos = InStrRev(FileName, ".")
If Pos > 0 Then Ext = Mid(FileName, Pos+1)
ewUploadAllowedFileExt = False
For Each FileExt in arExt
If LCase(Trim(FileExt)) = LCase(Ext) Then
ewUploadAllowedFileExt = True
Exit For
End If
Next
End Function
' Function to include the last delimiter for a path
Function ewIncludeTrailingDelimiter(Path, PhyPath)
If PhyPath Then
If Right(Path, 1) <> "\" Then Path = Path & "\"
Else
If Right(Path, 1) <> "/" Then Path = Path & "/"
End If
ewIncludeTrailingDelimiter = Path
End Function
' Function to write the paths for config/debug only
Sub ewWriteUploadPaths
Response.Write "Request.ServerVariables(""APPL_PHYSICAL_PATH"")=" & _
Request.ServerVariables("APPL_PHYSICAL_PATH") & "
"
Response.Write "Request.ServerVariables(""APPL_MD_PATH"")=" & _
Request.ServerVariables("APPL_MD_PATH") & "
"
End Sub
'===============================================================================
' Other functions for file upload (Do not modify)
Function stringToByte(toConv)
Dim i, tempChar
For i = 1 to Len(toConv)
tempChar = Mid(toConv, i, 1)
stringToByte = stringToByte & ChrB(AscB(tempChar))
Next
End Function
Private Function ByteToString(ToConv)
On Error Resume Next
For I = 1 to LenB(ToConv)
ByteToString = ByteToString & Chr(AscB(MidB(ToConv,i,1)))
Next
End Function
Function ConvertToBinary(RawData)
Dim oRs
Set oRs = Server.CreateObject("ADODB.Recordset")
' Create field in an empty RecordSet
Call oRs.Fields.Append("Blob", 205, LenB(RawData)) ' Add field with type adLongVarBinary
Call oRs.Open()
Call oRs.AddNew()
Call oRs.Fields("Blob").AppendChunk(RawData & ChrB(0))
Call oRs.Update()
' Save Blob Data
ConvertToBinary = oRs.Fields("Blob").GetChunk(LenB(RawData))
' Close RecordSet
Call oRs.Close()
Set oRs = Nothing
End Function
Function ConvertToUnicode(RawData)
Dim oRs
Set oRs = Server.CreateObject("ADODB.Recordset")
' Create field in an empty recordset
Call oRs.Fields.Append("Text", 201, LenB(RawData)) ' Add field with type adLongVarChar
Call oRs.Open()
Call oRs.AddNew()
Call oRs.Fields("Text").AppendChunk(RawData & ChrB(0))
Call oRs.Update()
' Save Unicode Data
ConvertToUnicode = oRs.Fields("Text").Value
' Close recordset
Call oRs.Close()
Set oRs = Nothing
End Function
Function ConvertToText(objStream, iStart, iLength, binData)
On Error Resume Next
If EW_UploadCharset <> "" Then
Dim tmpStream
Set tmpStream = Server.CreateObject("ADODB.Stream")
tmpStream.Type = 1 'adTypeBinary
tmpStream.Mode = 3 'adModeReadWrite
tmpStream.Open
objStream.Position = iStart
objStream.CopyTo tmpStream, iLength
tmpStream.Position = 0
tmpStream.Type = 2 'adTypeText
tmpStream.Charset = EW_UploadCharset
ConvertToText = tmpStream.ReadText
tmpStream.Close
Set tmpStream = Nothing
Else
ConvertToText = ByteToString(binData)
End If
ConvertToText = Trim(ConvertToText & "")
End Function
Function getValue(dict, name)
Dim gv
If dict.Exists(name) Then
gv = CStr(dict(name).Item("Value"))
gv = Left(gv, Len(gv)-2)
getValue = gv
Else
getValue = ""
End If
End Function
Function getFileData(dict, name)
If dict.Exists(name) Then
getFileData = dict(name).Item("Value")
If LenB(getFileData) Mod 2 = 1 Then
getFileData = getFileData & ChrB(0)
End If
Else
getFileData = ""
End If
End Function
Function getFileName(dict, name)
Dim temp, tempPos
If dict.Exists(name) Then
temp = dict(name).Item("FileName")
tempPos = 1 + InStrRev(temp, "\")
getFileName = Mid(temp, tempPos)
Else
getFileName = ""
End If
End Function
Function getFileSize(dict, name)
If dict.Exists(name) Then
getFileSize = LenB(dict(name).Item("Value"))
Else
getFileSize = 0
End If
End Function
Function getFileContentType(dict, name)
If dict.Exists(name) Then
getFileContentType = dict(name).Item("ContentType")
Else
getFileContentType = ""
End If
End Function
Function ewFolderExists(Folder)
Dim fso
Set fso = CreateObject("Scripting.FileSystemObject")
ewFolderExists = fso.FolderExists(Folder)
Set fso = Nothing
End Function
Sub ewDeleteFile(FilePath)
On Error Resume Next
Dim fso
Set fso = CreateObject("Scripting.FileSystemObject")
If FilePath <> "" And fso.FileExists(FilePath) Then
fso.DeleteFile(FilePath)
End If
Set fso = Nothing
End Sub
Sub ewRenameFile(OldFilePath, NewFilePath)
On Error Resume Next
Dim fso
Set fso = Server.CreateObject("Scripting.FileSystemObject")
If OldFilePath <> "" And fso.FileExists(OldFilePath) Then
fso.MoveFile OldFilePath, NewFilePath
End If
Set fso = Nothing
End Sub
Function ewCreateFolder(Folder)
On Error Resume Next
ewCreateFolder = False
Dim fso
Set fso = Server.CreateObject("Scripting.FileSystemObject")
If Not fso.FolderExists(Folder) Then
If ewCreateFolder(fso.GetParentFolderName(Folder)) Then
fso.CreateFolder(Folder)
If Err.Number = 0 Then ewCreateFolder = True
End If
Else
ewCreateFolder = True
End If
Set fso = Nothing
End Function
Function ewSaveFile(Folder, FileName, FileData)
On Error Resume Next
ewSaveFile = False
If ewCreateFolder(Folder) Then
Set oStream = Server.CreateObject("ADODB.Stream")
oStream.Type = 1 ' 1=adTypeBinary
oStream.Open
oStream.Write ConvertToBinary(FileData)
oStream.SaveToFile Folder & FileName, 2 ' 2=adSaveCreateOverwrite
oStream.Close
Set oStream = Nothing
If Err.Number = 0 Then ewSaveFile = True
End If
End Function
Function ewConvertLength(b)
ewConvertLength = CLng(AscB(LeftB(b, 1)) + (AscB(RightB(b, 1)) * 256))
End Function
Function ewConvertLength2(b)
ewConvertLength2 = CLng(AscB(RightB(b, 1)) + (AscB(LeftB(b, 1)) * 256))
End Function
' Get image dimension
Sub ewGetImageDimension(img, wd, ht)
Dim sPNGHeader, sGIFHeader, sBMPHeader, sJPGHeader, sHeader, sImgType
sImgType = "(unknown)"
' image headers, do not changed
sPNGHeader = ChrB(137) & ChrB(80) & ChrB(78)
sGIFHeader = ChrB(71) & ChrB(73) & ChrB(70)
sBMPHeader = ChrB(66) & ChrB(77)
sJPGHeader = ChrB(255) & ChrB(216) & ChrB(255)
sHeader = MidB(img, 1, 3)
' Handle GIF
If sHeader = sGIFHeader Then
sImgType = "GIF"
wd = ewConvertLength(MidB(img, 7, 2))
ht = ewConvertLength(MidB(img, 9, 2))
' Handle BMP
ElseIf LeftB(sHeader, 2) = sBMPHeader Then
sImgType = "BMP"
wd = ewConvertLength(MidB(img, 19, 2))
ht = ewConvertLength(MidB(img, 23, 2))
' Handle PNG
ElseIf sHeader = sPNGHeader Then
sImgType = "PNG"
wd = ewConvertLength2(MidB(img, 19, 2))
ht = ewConvertLength2(MidB(img, 23, 2))
' Handle JPG
Else
Dim size, markersize, pos, bEndLoop
size = LenB(img)
pos = InStrB(img, sJPGHeader)
If pos <= 0 Then
wd = -1
ht = -1
Exit Sub
End If
sImgType = "JPG"
pos = pos + 2
bEndLoop = False
Do While Not bEndLoop and pos < size
Do While AscB(MidB(img, pos, 1)) = 255 and pos < size
pos = pos + 1
Loop
If AscB(MidB(img, pos, 1)) < 192 or AscB(MidB(img, pos, 1)) > 195 Then
markersize = ewConvertLength2(MidB(img, pos+1, 2))
pos = pos + markersize + 1
Else
bEndLoop = True
End If
Loop
If Not bEndLoop Then
wd = -1
ht = -1
Else
wd = ewConvertLength2(MidB(img, pos+6, 2))
ht = ewConvertLength2(MidB(img, pos+4, 2))
End If
End If
End Sub
%>
<%
Response.Expires = 0
Response.ExpiresAbsolute = Now() - 1
Response.AddHeader "pragma", "no-cache"
Response.AddHeader "cache-control", "private, no-cache, no-store, must-revalidate"
%>
<%
' Initialize common variables
x_ID = Null: ox_ID = Null: z_ID = Null
x_sReceiverEmail = Null: ox_sReceiverEmail = Null: z_sReceiverEmail = Null
x_firstname = Null: ox_firstname = Null: z_firstname = Null
x_lastname = Null: ox_lastname = Null: z_lastname = Null
x_address = Null: ox_address = Null: z_address = Null
x_aptsuite = Null: ox_aptsuite = Null: z_aptsuite = Null
x_city = Null: ox_city = Null: z_city = Null
x_state = Null: ox_state = Null: z_state = Null
x_postalcode = Null: ox_postalcode = Null: z_postalcode = Null
x_telephone = Null: ox_telephone = Null: z_telephone = Null
x_cellphone = Null: ox_cellphone = Null: z_cellphone = Null
x_fax = Null: ox_fax = Null: z_fax = Null
x_email = Null: ox_email = Null: z_email = Null
x_remarks = Null: ox_remarks = Null: z_remarks = Null
%>
<%
Response.Buffer = True
' Load key from QueryString
bCopy = True
x_ID = Request.QueryString("ID")
If x_ID = "" Or IsNull(x_ID) Then
bCopy = False
End If
' Get action
sAction = Request.Form("a_add")
If (sAction = "" Or IsNull(sAction)) Then
If bCopy Then
sAction = "C" ' Copy record
Else
sAction = "I" ' Display blank record
End If
Else
' Get fields from form
x_ID = Request.Form("x_ID")
x_sReceiverEmail = Request.Form("x_sReceiverEmail")
x_firstname = Request.Form("x_firstname")
x_lastname = Request.Form("x_lastname")
x_address = Request.Form("x_address")
x_aptsuite = Request.Form("x_aptsuite")
x_city = Request.Form("x_city")
x_state = Request.Form("x_state")
x_postalcode = Request.Form("x_postalcode")
x_telephone = Request.Form("x_telephone")
x_cellphone = Request.Form("x_cellphone")
x_fax = Request.Form("x_fax")
x_email = Request.Form("x_email")
x_remarks = Request.Form("x_remarks")
End If
' Open connection to the database
Set conn = Server.CreateObject("ADODB.Connection")
conn.Open xDb_Conn_Str
Select Case sAction
Case "C": ' Get a record to display
If Not LoadData() Then ' Load Record based on key
Session(ewSessionMessage) = "No records found"
conn.Close ' Close Connection
Set conn = Nothing
Response.Clear
Response.Redirect "pageview.asp"
End If
Case "A": ' Add
If AddData() Then ' Add New Record
Session(ewSessionMessage) = "Message Sent Successfully"
conn.Close ' Close Connection
Set conn = Nothing
Response.Clear
Response.Redirect "contactadd.asp"
Else
End If
End Select
%>
<%
If Session(ewSessionMessage) <> "" Then
%>
<%= Session(ewSessionMessage) %>
<%
Session(ewSessionMessage) = "" ' Clear message
End If
%>
<%
conn.Close ' Close Connection
Set conn = Nothing
%>
<%
'-------------------------------------------------------------------------------
' Function LoadData
' - Load Data based on Key Value
' - Variables setup: field variables
Function LoadData()
Dim rs, sSql, sFilter
sFilter = ewSqlKeyWhere
If Not IsNumeric(x_ID) Then
LoadData = False
Exit Function
End If
sFilter = Replace(sFilter, "@ID", AdjustSql(x_ID)) ' Replace key value
sSql = ewBuildSql(ewSqlSelect, ewSqlWhere, ewSqlGroupBy, ewSqlHaving, ewSqlOrderBy, sFilter, "")
Set rs = Server.CreateObject("ADODB.Recordset")
rs.Open sSql, conn
If rs.Eof Then
LoadData = False
Else
LoadData = True
rs.MoveFirst
' Get the field contents
x_ID = rs("ID")
x_sReceiverEmail = rs("sReceiverEmail")
x_firstname = rs("firstname")
x_lastname = rs("lastname")
x_address = rs("address")
x_aptsuite = rs("aptsuite")
x_city = rs("city")
x_state = rs("state")
x_postalcode = rs("postalcode")
x_telephone = rs("telephone")
x_cellphone = rs("cellphone")
x_fax = rs("fax")
x_email = rs("email")
x_remarks = rs("remarks")
End If
rs.Close
Set rs = Nothing
End Function
%>
<%
'-------------------------------------------------------------------------------
' Function AddData
' - Add Data
' - Variables used: field variables
Function AddData()
On Error Resume Next
Dim rs, sSql, sFilter
Dim rsnew
Dim bCheckKey, sSqlChk, sWhereChk
sFilter = ewSqlKeyWhere
' Check for duplicate key
bCheckKey = True
If x_ID = "" Or IsNull(x_ID) Then
bCheckKey = False
Else
sFilter = Replace(sFilter, "@ID", AdjustSql(x_ID)) ' Replace key value
End If
If Not IsNumeric(x_ID) Then
bCheckKey = False
End If
If bCheckKey Then
sSqlChk = ewBuildSql(ewSqlSelect, ewSqlWhere, ewSqlGroupBy, ewSqlHaving, ewSqlOrderBy, sFilter, "")
Set rsChk = conn.Execute(sSqlChk)
If Err.Number <> 0 Then
Session(ewSessionMessage) = Err.Description
rsChk.Close
Set rsChk = Nothing
AddData = False
Exit Function
ElseIf Not rsChk.Eof Then
Session(ewSessionMessage) = "Duplicate value for primary key"
rsChk.Close
Set rsChk = Nothing
AddData = False
Exit Function
End If
rsChk.Close
Set rsChk = Nothing
End If
' Add New Record
sFilter = "(0 = 1)"
sSql = ewBuildSql(ewSqlSelect, ewSqlWhere, ewSqlGroupBy, ewSqlHaving, ewSqlOrderBy, sFilter, "")
Set rs = Server.CreateObject("ADODB.Recordset")
rs.CursorLocation = 2
rs.Open sSql, conn, 1, 2
If Err.Number <> 0 Then
Session(ewSessionMessage) = Err.Description
rs.Close
Set rs = Nothing
AddData = False
Exit Function
End If
rs.AddNew
' Field sReceiverEmail
sTmp = Trim(x_sReceiverEmail)
If Trim(sTmp) = "" Then sTmp = Null
rs("sReceiverEmail") = sTmp
' Field firstname
sTmp = Trim(x_firstname)
If Trim(sTmp) = "" Then sTmp = Null
rs("firstname") = sTmp
' Field lastname
sTmp = Trim(x_lastname)
If Trim(sTmp) = "" Then sTmp = Null
rs("lastname") = sTmp
' Field address
sTmp = Trim(x_address)
If Trim(sTmp) = "" Then sTmp = Null
rs("address") = sTmp
' Field aptsuite
sTmp = Trim(x_aptsuite)
If Trim(sTmp) = "" Then sTmp = Null
rs("aptsuite") = sTmp
' Field city
sTmp = Trim(x_city)
If Trim(sTmp) = "" Then sTmp = Null
rs("city") = sTmp
' Field state
sTmp = Trim(x_state)
If Trim(sTmp) = "" Then sTmp = Null
rs("state") = sTmp
' Field postalcode
sTmp = Trim(x_postalcode)
If Trim(sTmp) = "" Then sTmp = Null
rs("postalcode") = sTmp
' Field telephone
sTmp = Trim(x_telephone)
If Trim(sTmp) = "" Then sTmp = Null
rs("telephone") = sTmp
' Field cellphone
sTmp = Trim(x_cellphone)
If Trim(sTmp) = "" Then sTmp = Null
rs("cellphone") = sTmp
' Field fax
sTmp = Trim(x_fax)
If Trim(sTmp) = "" Then sTmp = Null
rs("fax") = sTmp
' Field email
sTmp = Trim(x_email)
If Trim(sTmp) = "" Then sTmp = Null
rs("email") = sTmp
' Field remarks
sTmp = Trim(x_remarks)
If Trim(sTmp) = "" Then sTmp = Null
rs("remarks") = sTmp
' Call recordset inserting event
If Recordset_Inserting(rs) Then
' Clone new rs object
Set rsnew = CloneRs(rs)
rs.Update
If Err.Number <> 0 Then
Session(ewSessionMessage) = Err.Description
AddData = False
Else
AddData = True
End If
Else
rs.CancelUpdate
AddData = False
End If
rs.Close
Set rs = Nothing
' Call recordset inserted event
If AddData Then
Call Recordset_Inserted(rsnew)
End If
rsnew.Close
Set rsnew = Nothing
End Function
'-------------------------------------------------------------------------------
' Recordset inserting event
Function Recordset_Inserting(rsnew)
On Error Resume Next
' Please enter your customized codes here
Recordset_Inserting = True
End Function
'-------------------------------------------------------------------------------
' Recordset inserted event
Sub Recordset_Inserted(rsnew)
On Error Resume Next
Dim table
table = "contact"
' Get key value
Dim sKey
sKey = ""
If sKey <> "" Then sKey = sKey & ","
sKey = sKey & rsnew.Fields("ID")
x_ID = rsnew.Fields("ID")
' Send Email
Dim sSenderEmail, sReceiverEmail
sSenderEmail = "support@fieldhousefitness.net" ' sender email
sReceiverEmail = x_sReceiverEmail ' receiver email
If sSenderEmail <> "" And sReceiverEmail <> "" Then
Call LoadEmail("notify.txt")
sEmailFrom = Replace(sEmailFrom, "", sSenderEmail) ' Replace Sender
sEmailTo = Replace(sEmailTo, "", sReceiverEmail) ' Replace Receiver
sEmailCc = Replace(sEmailCc, "", x_Email) ' Send Cc
sEmailSubject = Replace(sEmailSubject, "", table & " record inserted") ' Replace Subject
sEmailContent = Replace(sEmailContent, "", table)
sEmailContent = Replace(sEmailContent, "", sKey)
sEmailContent = Replace(sEmailContent, "", "Inserted")
sEmailContent = Replace(sEmailContent, "", x_firstname)
sEmailContent = Replace(sEmailContent, "", x_lastname)
sEmailContent = Replace(sEmailContent, "", x_address)
sEmailContent = Replace(sEmailContent, "", x_aptsuite)
sEmailContent = Replace(sEmailContent, "", x_city)
sEmailContent = Replace(sEmailContent, "", x_state)
sEmailContent = Replace(sEmailContent, "", x_postalcode)
sEmailContent = Replace(sEmailContent, "", x_telephone)
sEmailContent = Replace(sEmailContent, "", x_cellphone)
sEmailContent = Replace(sEmailContent, "", x_fax)
sEmailContent = Replace(sEmailContent, "", x_email)
sEmailContent = Replace(sEmailContent, "", x_remarks)
Call Send_Email(sEmailFrom, sEmailTo, sEmailCc, sEmailBcc, sEmailSubject, sEmailContent, sEmailFormat)
End If
End Sub
%> |
