 |
|||
 |
|
||
|
<%
Const objTypeWebsiteLink = 2
Const objTypeRace = 3
Const objTypeTrack = 4
Const objTypeTVScheduleEntry = 5
Const objTypeHorse = 6
Const objTypeContest = 7
Const validate = ""
Const imgPath = "/images/upload/"
Const http_instruction = "Please be sure to include the http:// before your address"
Const Cancel = ""
Const logPath = "E:\websites\academy-afs.org\admin\mdb\"
'Const logPath = "D:\websites\academy-afs.org folder\academy-afs.org\admin\mdb\"
CONST EnableLogging = false
%>
<%
'****************************************************************************************
'** © Copyright Notice
'**
'** Data Helper ASP Object Class -- ProApp ASP 3 Framework
'**
'** © 2002 ProApp Design, Inc. All Rights Reserved.
'**
'** All copyright notices must remain intact in the scripts.
'**
'** 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.
'**
'** This code is distributed WITHOUT ANY WARRANTY; without even the implied warranty of
'** MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE OR ANY OTHER
'** WARRANTIES WHETHER EXPRESSED OR IMPLIED.
'**
'** No official support is available for this program, because it is propreitary unsupported code
'**
'** http://www.proapp.net/
'****************************************************************************************
Class DataHelper
Private pa_ConnectionString
Private pa_SQLCommandText
private pa_cn
private pa_cmd
Private pa_parameters
private firstparam
Sub Class_Initialize()
pa_ConnectionString = application("ConnectionString")
pa_SQLCommandText = ""
GetDbCommand
End Sub
Sub Class_Terminate()
CloseConnection
set pa_cn = nothing
set pa_cmd = nothing
End Sub
Private Function GetDbCommand()
OpenConnection
set pa_cmd = server.CreateObject("ADODB.Command")
pa_cmd.CommandType = adCmdText
Set pa_cmd.ActiveConnection = pa_cn
Set GetDbCommand = pa_cmd
End Function
Private Sub GetDbConnection()
set pa_cn = Server.Createobject("ADODB.Connection")
pa_cn.ConnectionString = pa_ConnectionString
pa_cn.CursorLocation = adUseClient
pa_cn.Open
End Sub
Private Sub OpenConnection()
GetDbConnection()
End Sub
Private Sub CloseConnection()
pa_cn.Close
End Sub
Private Function SetParameter(dir,name,val)
dim paramsize, paramtype, param
if isnumeric(val) then
paramtype = adDouble
paramsize = 8
elseif len(val) <= 255 then
paramtype = adVarChar
paramsize = 255
elseif not isnull(val) then
paramtype = adVarChar
paramsize = 536870910
else
objLog.write "Null Value : " & name
paramtype = adVarChar
paramsize = 255
end if
on error resume next
Set param = pa_cmd.CreateParameter(name,paramtype,dir,paramsize,val)
if err.number <> 0 then
objLog.critical "name:" & name
objLog.critical "dir: " & dir
objLog.critical "value: " & value & " (Length: " & len(val) & ",IsNull : " & isnull(value) & ", isArray: " & isArray(value) & ", isObject: " & isObject(value) & ")"
objLog.critical "ParamType: " & paramtype & " [Types: adDouble: " & adDouble & ", adVarChar: " & adVarChar & "]"
objLog.critical "ParamSize: " & paramsize
objLog.critical err.number & " : " & err.description
response.end
end if
on error goto 0
pa_cmd.parameters.append param
End Function
Public Sub AddParameter2(direction,ParamName,ParamVal)
call SetParameter(direction,ParamName,ParamVal)
End Sub
Public Sub AddParameter(ParamName, ParamVal)
AddParameter2 adParamInput, ParamName, ParamVal
End Sub
Public Function ExecuteCommand_NoReturn()
on error resume next
dim result
pa_cmd.Execute result
if err.number <> 0 then
objLog.critical "An Error Occurred : " & err.number & " " & err.description & " SQL: " & pa_cmd.commandtext response.end end if on error goto 0 ExecuteCommand_NoReturn = result End Function Public Function ExecuteCommand_ReturnRecordset() on error resume next Set ExecuteCommand_ReturnRecordset = pa_cmd.Execute if err.number <> 0 then objLog.critical "An Error Occurred : " & err.number & " " & err.description & " SQL: " & pa_cmd.commandtext response.end end if on error goto 0 Set ExecuteCommand_ReturnRecordset.ActiveConnection = nothing End Function Public Sub ClearParameters() pa_parameters = empty End Sub Public Property Get SQLCommandText() SQLCommandText = pa_sqlcommandtext End Property Public Property Let SQLCommandText(Value) pa_sqlcommandtext = value pa_cmd.CommandText = pa_SQLCommandText End Property Public Property Get ConnectionString() ConnectionString = pa_connectionstring End Property Public Property Let ConnectionString(Value) pa_connectionstring = Value End Property function delete_object(tablename, fieldname, key) reset SQLCommandText = "DELETE FROM " & tablename & " WHERE " & fieldname & "=?" AddParameter "key", key ExecuteCommand_NoReturn objLog.write "Deleted Object (" & tablename & "," & fieldname & "," & key & ")" end function function get_update_statement(tablename, byval keys) dim buf, ques(), ub,i ub = ubound(keys) for i = 0 to ub - 1 keys(i) = "[" & keys(i) & "]=?" next buf = join(keys, ",") buf = replace(buf, "," & keys(ub), "") get_update_statement = "UPDATE " & tablename & " Set " & buf & " WHERE [" & keys(ub) & "]=?" end function function update(tablename, keys, values) dim ub,i reset sqlcommandtext = get_update_statement(tablename,keys) ub = ubound(keys) for i = 0 to ub addparameter keys(i), values(i) next update = (executecommand_noreturn > 0) if err.number <> 0 then objLog.critical "SQL: " & sqlcommandtext objLog.critical "Error: " & err.number & " / " & err.description response.end end if end function function get_insert_statement(tablename, keys) dim buf, ques(), ub,i ub = ubound(keys) for i = 0 to ub keys(i) = "[" & keys(i) & "]" next buf = "INSERT INTO " & tablename & " (" & join(keys, ",") & ") VALUES (" redim ques(ub) for i = 0 to ub ques(i) = "?" next get_insert_statement = buf & join(ques,",") & ")" end function function insert(tablename, keys, values) dim ub,i reset sqlcommandtext = get_insert_statement(tablename,keys) objLog.write "Insert Statement: " & sqlcommandtext ub = ubound(keys) objLog.write "Number of keys: " & ub for i = 0 to ub objLog.Write "Add Parameter: " & keys(i) & " : " & u.iif(isnull(values(i)), "NULL", values(i)) addparameter keys(i), values(i) next objLog.write "Ready to Execute" insert = (executecommand_noreturn > 0) objLog.write "Executed, result: " & insert if err.number <> 0 then objLog.write "SQL: " & sqlcommandtext objLog.write "Error: " & err.number & " / " & err.description response.end end if end function function Get_Last_Identity() Dim rs SQLCommandText = "SELECT @@IDENTITY As ID" set rs = ExecuteCommand_ReturnRecordset Get_Last_Identity = rs(0) rs.close set rs = nothing end function function getRS(strSQL) reset SQLCommandText = strSQL set GetRS = ExecuteCommand_ReturnRecordset end function function getArrayFromRS(strSQL) dim rs set rs = getrs(strSQL) if rs.eof then getArrayFromRS = empty else getArrayFromRS = rs.GetRows end if rs.close set rs = nothing end function public sub Reset() ClearParameters CloseConnection set pa_cn = nothing set pa_cmd = nothing pa_ConnectionString = application("ConnectionString") pa_SQLCommandText = "" GetDbCommand End sub End Class %> <% '**************************************************************************************** '** © Copyright Notice '** '** String / Misc Utility ASP Object Class -- ProApp ASP 3 Framework '** '** © 2002 ProApp Design, Inc. All Rights Reserved. '** '** All copyright notices must remain intact in the scripts. '** '** 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. '** '** This code is distributed WITHOUT ANY WARRANTY; without even the implied warranty of '** MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE OR ANY OTHER '** WARRANTIES WHETHER EXPRESSED OR IMPLIED. '** '** No official support is available for this program, because it is propreitary unsupported code '** '** http://www.proapp.net/ '**************************************************************************************** Class Utility function GetText(name) if ismultipart then GetText = nvl(upl.form(name),null) else GetText = nvl(request(name),null) end if end function function GetNumber(name) if ismultipart then GetNumber = nvl(upl.form(name),0) else GetNumber = nvl(request(name),0) end if end function function GetDate(name) if ismultipart then GetDate = nvl(upl.form(name),cdate("1/1/80")) else GetDate = nvl(request(name),cdate("1/1/80")) end if end function function GetMemo(name) if ismultipart then GetMemo = memo(upl.form(name)) else GetMemo = memo(request(name)) end if end function function RomanOnes(num) do until num < 1 RomanOnes = RomanOnes & "I" num = num - 1 loop end function function RomanFives(num) do until num < 5 RomanFives = RomanFives & "V" num = num - 5 loop end function function RomanTens(num) RomanTens = "" do until num < 10 RomanTens = RomanTens & "X" num = num - 10 loop end function function RomanFifties(num) RomanTens = "" do until num < 50 RomanFifties = RomanFifties & "L" num = num - 50 loop end function function toRoman(num) toRoman = "" if right(cstr(num),1) = "4" OR right(cstr(num),1) = "9" then num = num + 1 toRoman = "I" end if do until num = 0 if num >= 50 then toRoman = toRoman & RomanFifties(num) end if if num >= 10 and num < 50 then toRoman = toRoman & RomanTens(num) end if if num >= 5 and num < 10 then toRoman = toRoman & RomanFives(num) end if if num >= 1 and num < 5 then toRoman = toRoman & RomanOnes(num) end if loop end function function NewObjectID(objName, objType) dim dh set dh = new datahelper dh.Insert "ObjectList", _ Array("Title", "Type"), _ Array(objName, objType) NewObjectID = dh.Get_Last_Identity set dh = nothing end function public function nvl(value, subst) if isnull(value) then nvl = subst else if len(value) > 0 then nvl = value else nvl = subst end if end if end function 'Replaces all Carriage Returns in a memo field with " " tags for display function memo(value) memo = iif(isnull(nvl(value, null)), null, replace(value, vbcrlf, " ")) end function 'Replaces all " " tags in a memo field with Carriage Returns for editing function display_memo(value) if isnull(nvl(value,null)) then display_memo = "" else display_memo = replace(value, " ", vbcrlf) end if end function public function iif(expr, trueval, falseval) if (expr) then iif = trueval else iif = falseval end if end function public Function Proper(InString) Dim FoundSpace, OutputString, MidPostition if InString = "" then InString = " " InString = Replace(InString, "'","''") FoundSpace = True OutputString = "" for MidPosition = 1 to len(InString) if FoundSpace = true then OutputString = OutputString & UCase(Mid(InString,MidPosition,1)) FoundSpace = false else OutputString = OutputString & LCase(Mid(InString,MidPosition,1)) if Mid(InString,MidPosition,1) = " " then FoundSpace = true if Mid(InString,MidPosition,1) = chr(10) then FoundSpace = true end if next Proper = OutputString End Function function removeQuotes(strValue) removeQuotes = replace(strValue, """", """) end function function removeSingleQuotes(strValue) removeSingleQuotes = replace(strValue, "'", "\'") end function function ConvertHTMLtoText(strValue) dim buf buf = replace(strValue, "<", "<") buf = replace(buf, ">", ">") ConvertHTMLtoText = buf end function function displayTextField(recordset, fieldname) Dim strbuf 'Get original value strbuf=nvl(recordset(fieldname),"") 'Process characters strbuf=removeQuotes(strbuf) 'Return processed field displayTextField = strBuf end function function displayJSField(recordset, fieldname) Dim strbuf 'Get original value strbuf=nvl(recordset(fieldname),"") 'Process characters strbuf=removeQuotes(strbuf) strbuf=removeSingleQuotes(strbuf) 'Return processed field displayJSField = strBuf end function function displayHTMLField(recordset, fieldname) dim strBuf strBuf = displayTextField(recordset, fieldname) displayHTMLField = ProcessHTML(strBuf) end function function ie(s) ie = imgPath & s end function End Class %> <% class LogtoFile Private ForReading Private ForWriting Private ForAppending Private objFSO, objFile sub class_initialize() Set objFSO = Server.CreateObject("Scripting.FileSystemObject") ForReading = 1 ForWriting = 2 ForAppending = 8 end sub sub class_terminate() set objFSO = nothing end sub sub openlog(urgent) if urgent then set objFile = objFSO.OpenTextFile(logPath & "critical.txt", ForAppending, true) else set objFile = objFSO.OpenTextFile(logPath & "log.txt", ForAppending, true) end if end sub sub closelog() objFile.close set objFile = nothing end sub sub write(val) val = now & " - [" & request.servervariables("server_name") & "] - " & request.servervariables("script_name") & " - {" & request.servervariables("QUERY_STRING") & "} - " & val if EnableLogging then call openlog(false) objFile.writeline(val) call closelog() end if end sub sub critical(val) val = now & " - [" & request.servervariables("server_name") & "] - " & request.servervariables("script_name") & " - {" & request.servervariables("QUERY_STRING") & "} - " & val call openlog(true) objFile.writeline(val) call closelog() end sub end class %> <% '**************************************************************************************** '** © Copyright Notice '** '** ASP Common Include -- ProApp ASP 3 Framework '** '** © 2002 ProApp Design, Inc. All Rights Reserved. '** '** All copyright notices must remain intact in the scripts. '** '** 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. '** '** This code is distributed WITHOUT ANY WARRANTY; without even the implied warranty of '** MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE OR ANY OTHER '** WARRANTIES WHETHER EXPRESSED OR IMPLIED. '** '** No official support is available for this program, because it is propreitary unsupported code '** '** http://www.proapp.net/ '**************************************************************************************** dim upl, u, err_text, objRegExp, objLog set objLog = new LogToFile set u = new utility set objRegExp = new regexp if isMultipart then set upl = server.createobject("SoftArtisans.FileUp") end if function stripWhiteSpace(value) objRegExp.Pattern = "\s" objRegExp.IgnoreCase = True objRegExp.Global = true stripWhiteSpace = objRegExp.Replace(value,"") end function function get_pls(filename) get_pls = u.ie(get_base_filename(filename) & ".pls") end function function get_base_filename(filename) get_base_filename = lcase(left(filename, instrrev(filename, ".")-1)) end function public function TimeFormat(datetime) dim ampm if isnull(u.nvl(datetime,null)) then timeformat = "" exit function end if datetime = formatdatetime(datetime, 4) if cint(left(datetime, instr(datetime, ":") - 1)) > 12 then datetime = formatdatetime(dateadd("h", -12, datetime), 4) ampm = "pm" elseif cint(left(datetime, instr(datetime, ":") - 1)) = 12 then ampm = "pm" else ampm = "am" end if timeformat = datetime & ampm end function public function DeleteFile(filename) on error resume next set fm = server.createobject("SoftArtisans.FileManager") fm.deletefile server.mappath(filename) on error goto 0 end function public function isMultipart() Dim enctype enctype = request.servervariables("HTTP_CONTENT_TYPE") if instr(enctype, "multipart") > 0 then isMultipart = true else isMultipart = false end if end function public function IsPostBack() Dim validate if ismultipart then validate = upl.form("validate") else validate = request("validate") end if if len(validate) > 0 then ispostback = true else ispostback = false end if end function public function IsChildWindow() Dim child if ismultipart then child = upl.form("child") else child = request("child") end if if len(child) > 0 then IsChildWindow = true else IsChildWindow = false end if end function %> 
Ask the doctor
Ask the doctor a question, and get an answer. "Ask the Doc" is our members-only newsletter.
Please log into the members section (Click [Members Area] button on left) to access this feature. Click here to go there now! |
|
  |
Site Design and Hosting Provided by ProApp Consulting. |
|
|