<%
Option Explicit
'Include Files @0-0F8FBEEB
%>
<%
'End Include Files
'Script Engine Version Check @0-A118D8E9
If ScriptEngineMajorVersion < 5 Then
Response.Write "Sorry. This program requires VBScript 5.1 to run.
You may upgrade your VBScript at http://www.microsoft.com/msdownload/vbscript/scripting.asp."
Response.End
Else
If ScriptEngineMajorVersion & ":" & ScriptEngineMinorVersion = "5:0" Then
Response.Write "Due to a bug in VBScript 5.0, this program would crash your server. See http://support.microsoft.com/default.aspx?scid=kb;EN-US;q240811.
" & _
"Upgrade your VBScript at http://www.microsoft.com/msdownload/vbscript/scripting.asp."
Response.End
End If
End If
'End Script Engine Version Check
'Initialize Common Variables @0-A6FA9B5F
Dim CCSDateConstants
Dim ServerURL
Dim SecureURL
Dim TemplatesRepository
Dim EventCaller
Dim ParentPage
Dim DefaultDateFormat
Dim DefaultBooleanFormat
Dim IsMutipartEncoding
Dim objUpload
Dim UploadedFilesCount
IsMutipartEncoding = False
If InStr(Request.ServerVariables("CONTENT_TYPE"),"multipart/form-data") > 0 Then
On Error Resume Next
Set objUpload = Server.CreateObject("Persits.Upload")
objUpload.IgnoreNoPost = True
UploadedFilesCount = objUpload.Save
IsMutipartEncoding = True
If Err.Number > 0 Then
Response.Write "Persits uploading component ""Persits"" is not found. Please select another or install the component."
Response.End
End If
On Error Goto 0
End If
Set TemplatesRepository = New clsCache_FileSystem
DefaultDateFormat = Empty
DefaultBooleanFormat = Empty
ServerURL = "http://www3.kfshrc.edu.sa/annals/"
Set CCSDateConstants = New clsCCSDateConstants
Class clsCCSDateConstants
Public Weekdays
Public ShortWeekdays
Public Months
Public ShortMonths
Public DateMasks
Private Sub Class_Initialize()
ShortWeekdays = Array("Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat")
Weekdays = Array("Sunday", "Monday", "Tuesday", "Wednesday", "Thursday", "Friday", "Saturday")
ShortMonths = Array("Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec")
Months = Array("January", "February", "March", "April", "May", "June", "July", "August", "September", "October", "November", "December")
Set DateMasks = CreateObject("Scripting.Dictionary")
DateMasks("d") = 0
DateMasks("dd") = 2
DateMasks("m") = 0
DateMasks("mm") = 2
DateMasks("mmm") = 3
DateMasks("mmmm") = 0
DateMasks("yy") = 2
DateMasks("yyyy") = 4
DateMasks("h") = 0
DateMasks("hh") = 2
DateMasks("H") = 0
DateMasks("HH") = 2
DateMasks("n") = 0
DateMasks("nn") = 2
DateMasks("s") = 0
DateMasks("ss") = 2
DateMasks("am/pm") = 2
DateMasks("AM/PM") = 2
DateMasks("A/P") = 1
DateMasks("a/p") = 1
DateMasks("w") = 0
DateMasks("q") = 0
DateMasks("S") = 0
End Sub
Private Sub Class_Terminate()
Set DateMasks = Nothing
End Sub
End Class
Const ccsInteger = 1
Const ccsFloat = 2
Const ccsText = 3
Const ccsDate = 4
Const ccsBoolean = 5
Const ccsMemo = 6
Const ccsGet = 1
Const ccsPost = 2
'End Initialize Common Variables
'annals Connection Class @-B5F5541B
Class clsDBannals
Public ConnectionString
Public User
Public Password
Public DateFormat
Public BooleanFormat
Public LastSQL
Public Errors
Private objConnection
Private blnState
Private Sub Class_Initialize()
ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Server.MapPath("annals.mdb") & ";Persist Security Info=False"
User = "Admin"
Password = ""
DateFormat = Array("yyyy", "-", "mm", "-", "dd", " ", "HH", ":", "nn", ":", "ss")
BooleanFormat = Array("true", "false", Empty)
Set objConnection = Server.CreateObject("ADODB.Connection")
Set Errors = New clsErrors
End Sub
Sub Open()
On Error Resume Next
objConnection.Errors.Clear
objConnection.Open ConnectionString, User, Password
If Err.Number <> 0 then
Response.Write "Unable to establish connection to database.
"
Response.Write "
- Error information:
"
Response.Write Err.Source & " (0x" & Hex(Err.Number) & ")
"
Response.Write Err.Description & " "
If Err.Number = -2147467259 then _
Response.Write "- Other possible cause of this problem:
The database cannot be opened, most likely due to incorrect connection settings or insufficient security set on your database folder or file.
For more details please refer to http://support.microsoft.com/default.aspx?scid=kb;en-us;Q306518 "
Response.Write "
Form: " & Title & "
"
For i = 0 To Errors.Count - 1
Result = Result & "Error: " & Errors.ErrorByNumber(i)
If i < Errors.Count - 1 Then Result = Result & "
"
Next
Result = Result & "
"
CCFormatError = Result
End Function
'End CCFormatError
'CCOpenRS @0-9E4633EC
Function CCOpenRS(RecordSet, SQL, Connection, ShowError)
Dim ErrorMessage, Result
Result = Empty
Set RecordSet = Server.CreateObject("ADODB.Recordset")
On Error Resume Next
RecordSet.Open SQL, Connection, adOpenForwardOnly, adLockReadOnly, adCmdText
ErrorMessage = CCProcessError(Connection)
If NOT IsEmpty(ErrorMessage) Then
If ShowError Then _
Result = "SQL: " & CommandObject.CommandText & "
" & "Error: " & ErrorMessage & "
" _
Else _
Result = "Database error.
"
End If
On Error Goto 0
CCOpenRS = Result
End Function
'End CCOpenRS
'CCOpenRSFromCmd @0-A2A33ECF
Function CCOpenRSFromCmd(RecordSet, CommandObject, ShowError)
Dim ErrorMessage, Result
Result = Empty
Set RecordSet = Server.CreateObject("ADODB.Recordset")
On Error Resume Next
RecordSet.CursorType = adOpenForwardOnly
RecordSet.LockType = adLockReadOnly
RecordSet.Open CommandObject
ErrorMessage = CCProcessError(CommandObject.ActiveConnection)
If NOT IsEmpty(ErrorMessage) Then
If ShowError Then _
Result = "SQL: " & CommandObject.CommandText & "
" & "Error: " & ErrorMessage & "
" _
Else _
Result = "Database error.
"
End If
On Error Goto 0
CCOpenRSFromCmd = Result
End Function
'End CCOpenRSFromCmd
'CCExecCmd @0-3DC993D0
Function CCExecCmd(CommandObject, ShowError)
Dim ErrorMessage, Result
Result = Empty
On Error Resume Next
CommandObject.Execute
ErrorMessage = CCProcessError(CommandObject.ActiveConnection)
If NOT IsEmpty(ErrorMessage) Then
If ShowError Then _
Result = "SQL: " & CommandObject.CommandText & "
" & "Error: " & ErrorMessage & "
" _
Else _
Result = "Database error.
"
End If
On Error Goto 0
CCExecCmd = Result
End Function
'End CCExecCmd
'CCExecSQL @0-24CC2822
Function CCExecSQL(SQL, Connection, ShowError)
Dim ErrorMessage, Result
Result = Empty
On Error Resume Next
Connection.Execute(SQL)
ErrorMessage = CCProcessError(Connection)
If NOT IsEmpty(ErrorMessage) Then
If ShowError Then _
Result = "SQL: " & SQL & "
" & "Error: " & ErrorMessage & "
" _
Else _
Result = "Database error.
"
End If
On Error Goto 0
CCExecSQL = Result
End Function
'End CCExecSQL
'CCToHTML @0-44D2E9F4
Function CCToHTML(Value)
If IsNull(Value) Then Value = ""
CCToHTML = Server.HTMLEncode(Value)
End Function
'End CCToHTML
'CCToURL @0-23A93674
Function CCToURL(Value)
If IsNull(Value) Then Value = ""
CCToURL = Server.URLEncode(Value)
End Function
'End CCToURL
'CCGetValueHTML @0-30C69AED
Function CCGetValueHTML(RecordSet, FieldName)
CCGetValueHTML = CCToHTML(CCGetValue(RecordSet, FieldName))
End Function
'End CCGetValueHTML
'CCGetValue @0-C5915067
Function CCGetValue(RecordSet, FieldName)
Dim Result
On Error Resume Next
If RecordSet Is Nothing Then
CCGetValue = Empty
ElseIf (NOT RecordSet.EOF) AND (FieldName <> "") Then
Result = RecordSet(FieldName)
If IsNull(Result) Then _
Result = Empty
CCGetValue = Result
Else
CCGetValue = Empty
End If
On Error Goto 0
End Function
'End CCGetValue
'CCGetDate @0-4102C01B
Function CCGetDate(RecordSet, FieldName, arrDateFormat)
Dim Result
Result = CCGetValue(RecordSet, FieldName)
If Not IsEmpty(arrDateFormat) Then
If Not (VarType(Result) = vbDate OR VarType(Result) = vbEmpty) Then _
If CCValidateDate(Result, arrDateFormat) Then _
Result = CCParseDate(Result, arrDateFormat)
End If
CCGetDate = Result
End Function
'End CCGetDate
'CCGetBoolean @0-C64EED38
Function CCGetBoolean(RecordSet, FieldName, BooleanFormat)
Dim Result
Result = CCGetValue(RecordSet, FieldName)
CCGetBoolean = CCParseBoolean(Result, BooleanFormat)
End Function
'End CCGetBoolean
'CCGetParam @0-104BE777
Function CCGetParam(ParameterName, DefaultValue)
Dim ParameterValue : ParameterValue = ""
If IsMutipartEncoding Then
ParameterValue = objUpload.Form(ParameterName).Value
If ParameterValue = "" Then ParameterValue = DefaultValue
Else
If Request.QueryString(ParameterName).Count > 0 Then
ParameterValue = Request.QueryString(ParameterName)
ElseIf Request.Form(ParameterName).Count > 0 Then
ParameterValue = Request.Form(ParameterName)
Else
ParameterValue = DefaultValue
End If
End If
CCGetParam = ParameterValue
End Function
'End CCGetParam
'CCGetFromPost @0-E740B2C2
Function CCGetFromPost(ParameterName, DefaultValue)
Dim ParameterValue : ParameterValue = Empty
If IsMutipartEncoding Then
ParameterValue = objUpload.Form(ParameterName).Value
If ParameterValue = "" Then ParameterValue = DefaultValue
Else
ParameterValue = Request.Form(ParameterName)
If IsEmpty(ParameterValue) Then
ParameterValue = DefaultValue
End If
End If
CCGetFromPost = ParameterValue
End Function
'End CCGetFromPost
'CCGetFromGet @0-F6BB8115
Function CCGetFromGet(ParameterName, DefaultValue)
Dim ParameterValue : ParameterValue = Empty
ParameterValue = Request.QueryString(ParameterName)
If IsEmpty(ParameterValue) Then _
ParameterValue = DefaultValue
CCGetFromGet = ParameterValue
End Function
'End CCGetFromGet
'CCToSQL @0-CA2C324A
Function CCToSQL(Value, ValueType)
If CStr(Value) = "" OR IsEmpty(Value) Then
CCToSQL = "Null"
Else
If ValueType = "Integer" or ValueType = "Float" Then
CCToSQL = Replace(CDbl(Value), ",", ".")
Else
CCToSQL = "'" & Replace(Value, "'", "''") & "'"
End If
End If
End Function
'End CCToSQL
'CCDLookUp @0-7AA7ED74
Function CCDLookUp(ColumnName, TableName, Where, Connection)
Dim RecordSet
Dim Result
Dim SQL
Dim ErrorMessage
SQL = "SELECT " & ColumnName
If Len(CStr(TableName)) > 0 Then SQL = SQL & " FROM " & TableName
If Len(CStr(Where)) > 0 Then SQL = SQL & " WHERE " & Where
Set RecordSet = Connection.Execute(SQL)
ErrorMessage = CCProcessError(Connection)
If NOT IsEmpty(ErrorMessage) Then
PrintDBError "CCDLookUp function", SQL, ErrorMessage
End If
On Error Goto 0
Result = CCGetValue(RecordSet, 0)
CCDLookUp = Result
End Function
'End CCDLookUp
'PrintDBError @0-3D5DDA9A
Sub PrintDBError(Source, SQL, ErrorMessage)
Dim CommandText
Dim SourceText
Dim ErrorText
If Source <> "" Then SourceText = "Source: " & Source & "
"
If SQL <> "" Then CommandText = "Command Text: " & SQL & "
"
If ErrorMessage <> "" Then ErrorText = "Error description: " & ErrorMessage & ""
Response.Write "" & SourceText
Response.Write CommandText & ErrorText
End Sub
'End PrintDBError
'CCGetCheckBoxValue @0-ABCF54E0
Function CCGetCheckBoxValue(Value, CheckedValue, UncheckedValue, ValueType)
If isEmpty(Value) Then
If UncheckedValue = "" Then
CCGetCheckBoxValue = "Null"
Else
If ValueType = "Integer" or ValueType = "Float" Then
CCGetCheckBoxValue = UncheckedValue
Else
CCGetCheckBoxValue = "'" & Replace(UncheckedValue, "'", "''") & "'"
End If
End If
Else
If CheckedValue = "" Then
CCGetCheckBoxValue = "Null"
Else
If ValueType = "Integer" OR ValueType = "Float" Then
CCGetCheckBoxValue = CheckedValue
Else
CCGetCheckBoxValue = "'" & Replace(CheckedValue, "'", "''") & "'"
End If
End If
End If
End Function
'End CCGetCheckBoxValue
'CCGetValFromLOV @0-5041B9C1
Function CCGetValFromLOV(Value, ListOfValues)
Dim I
Dim Result : Result = ""
If (Ubound(ListOfValues) MOD 2) = 1 Then
For I = 0 To Ubound(ListOfValues) Step 2
If CStr(Value) = CStr(ListOfValues(I)) Then Result = ListOfValues(I + 1)
Next
End If
CCGetValFromLOV = Result
End Function
'End CCGetValFromLOV
'CCProcessError @0-A3A2654C
Function CCProcessError(Connection)
If Connection.Errors.Count > 0 Then
If TypeName(Connection) = "Connection" Then
CCProcessError = Connection.Errors(0).Description & " (" & Connection.Errors(0).Source & ")"
Else
CCProcessError = Connection.Errors.ToString
End If
ElseIf NOT (Err.Description = "") Then
CCProcessError = Err.Description
Else
CCProcessError = Empty
End If
end Function
'End CCProcessError
'CCGetRequestParam @0-D94A584B
Function CCGetRequestParam(ParameterName, Method)
Dim ParameterValue
If Method = ccsGet Then
ParameterValue = Request.QueryString(ParameterName)
ElseIf Method = ccsPost Then
If IsMutipartEncoding Then
ParameterValue = objUpload.Form(ParameterName).Value
If Len(ParameterValue) = 0 Then
Dim File
Set File = objUpload.Files(ParameterName)
If Not File is Nothing Then ParameterValue = File.FileName
End If
Else
ParameterValue = Request.Form(ParameterName)
End If
End If
If CStr(ParameterValue) = "" Then _
ParameterValue = Empty
CCGetRequestParam = ParameterValue
End Function
Function CCGetRequestMultipleParam(ParameterName, Method)
Dim ParameterValues(), ParamCount, i
If Method = ccsGet Then
ParamCount = Request.QueryString(ParameterName).Count
ReDim ParameterValues (ParamCount)
For i = 1 To ParamCount
ParameterValues(i) = Request.QueryString(ParameterName)(i)
If CStr(ParameterValues(i)) = "" Then ParameterValues(i) = Empty
Next
ElseIf Method = ccsPost Then
If IsMutipartEncoding Then
ParamCount = 1
ReDim ParameterValues (ParamCount)
ParameterValues(ParamCount) = objUpload.Form(ParameterName).Value
Else
ParamCount = Request.Form(ParameterName).Count
ReDim ParameterValues (ParamCount)
For i = 1 To ParamCount
ParameterValues(i) = Request.Form(ParameterName)(i)
If CStr(ParameterValues(i)) = "" Then ParameterValues(i) = Empty
Next
End If
End If
CCGetRequestMultipleParam = ParameterValues
End Function
'End CCGetRequestParam
'CCGetQueryString @0-CBD7B22E
Function CCGetQueryString(CollectionName, RemoveParameters)
Dim QueryString, PostData
If CollectionName = "Form" Then
QueryString = CCCollectionToString(Request.Form, RemoveParameters)
ElseIf CollectionName = "QueryString" Then
QueryString = CCCollectionToString(Request.QueryString, RemoveParameters)
ElseIf CollectionName = "All" Then
QueryString = CCCollectionToString(Request.QueryString, RemoveParameters)
PostData = CCCollectionToString(Request.Form, RemoveParameters)
If Len(PostData) > 0 and Len(QueryString) > 0 Then _
QueryString = QueryString & "&" & PostData _
Else _
QueryString = QueryString & PostData
Else
Err.Raise 1050, "Common Functions. CCGetQueryString Function", _
"The CollectionName contains an illegal value."
End If
CCGetQueryString = QueryString
End Function
'End CCGetQueryString
'CCCollectionToString @0-57CAA4B7
Function CCCollectionToString(ParametersCollection, RemoveParameters)
Dim ItemName, ItemValue, Result, Remove, I
For Each ItemName In ParametersCollection
Remove = false
If IsArray(RemoveParameters) Then
For I = 0 To UBound(RemoveParameters)
If RemoveParameters(I) = ItemName Then
Remove = True
Exit For
End If
Next
End If
If Not Remove Then
For Each ItemValue In ParametersCollection(ItemName)
Result = Result & _
"&" & ItemName & "=" & Server.URLEncode(ItemValue)
Next
End If
Next
If Len(Result) > 0 Then _
Result = Mid(Result, 2)
CCCollectionToString = Result
End Function
'End CCCollectionToString
'CCAddZero @0-B5648418
Function CCAddZero(Value, ResultLength)
Dim CountZero, I
CountZero = ResultLength - Len(Value)
For I = 1 To CountZero
Value = "0" & Value
Next
CCAddZero = Value
End Function
'End CCAddZero
'CCGetAMPM @0-CB6EA5BF
Function CCGetAMPM(HoursNumber, AnteMeridiem, PostMeridiem)
If HoursNumber >= 0 And HoursNumber < 12 Then
CCGetAMPM = AnteMeridiem
Else
CCGetAMPM = PostMeridiem
End If
End Function
'End CCGetAMPM
'CC12Hour @0-12B00AFF
Function CC12Hour(HoursNumber)
If HoursNumber = 0 Then
HoursNumber = 12
ElseIf HoursNumber > 12 Then
HoursNumber = HoursNumber - 12
End If
CC12Hour = HoursNumber
End Function
'End CC12Hour
'CCDBFormatByType @0-531721B5
Function CCDBFormatByType(Variable)
Dim Result
If VarType(Variable) = vbString Then
If LCase(Variable) = "null" Then
Result = Variable
Else
Result = "'" & Variable & "'"
End If
Else
Result = CStr(Variable)
End If
CCDBFormatByType = Result
End Function
'End CCDBFormatByType
'CCFormatDate @0-3DB0C52B
Function CCFormatDate(DateToFormat, FormatMask)
Dim ResultArray(), I, Result
If VarType(DateToFormat) = vbEmpty Then
Result = Empty
ElseIf VarType(DateToFormat) <> vbDate Then
Err.Raise 4000, "CCFormatDate function. Type mismatch."
ElseIf IsEmpty(FormatMask) Then
Result = CStr(DateToFormat)
Else
ReDim ResultArray(UBound(FormatMask))
For I = 0 To UBound(FormatMask)
Select Case FormatMask(I)
Case "d" ResultArray(I) = Day(DateToFormat)
Case "w" ResultArray(I) = Weekday(DateToFormat)
Case "m" ResultArray(I) = Month(DateToFormat)
Case "q" ResultArray(I) = (Month(DateToFormat) + 3) \ 4
Case "y" ResultArray(I) = (DateDiff("d", "1/1" & "/" & Year(DateToFormat), Month(DateToFormat) & "/" & Day(DateToFormat) & "/" & Year(DateToFormat)) + 1)
Case "h" ResultArray(I) = CC12Hour(Hour(DateToFormat))
Case "H" ResultArray(I) = Hour(DateToFormat)
Case "n" ResultArray(I) = Minute(DateToFormat)
Case "s" ResultArray(I) = Second(DateToFormat)
Case "dd" ResultArray(I) = CCAddZero(Day(DateToFormat), 2)
Case "ww" ResultArray(I) = (DateDiff("ww", "1/1" & "/" & Year(DateToFormat), Month(DateToFormat) & "/" & Day(DateToFormat) & "/" & Year(DateToFormat)) + 1)
Case "mm" ResultArray(I) = CCAddZero(Month(DateToFormat), 2)
Case "yy" ResultArray(I) = Right(Year(DateToFormat), 2)
Case "hh" ResultArray(I) = CCAddZero(CC12Hour(Hour(DateToFormat)), 2)
Case "HH" ResultArray(I) = CCAddZero(Hour(DateToFormat), 2)
Case "nn" ResultArray(I) = CCAddZero(Minute(DateToFormat), 2)
Case "ss" ResultArray(I) = CCAddZero(Second(DateToFormat), 2)
Case "S" ResultArray(I) = "000"
Case "ddd" ResultArray(I) = CCSDateConstants.ShortWeekdays(Weekday(DateToFormat) - 1)
Case "mmm" ResultArray(I) = CCSDateConstants.ShortMonths(Month(DateToFormat) - 1)
Case "A/P" ResultArray(I) = CCGetAMPM(Hour(DateToFormat), "A", "P")
Case "a/p" ResultArray(I) = CCGetAMPM(Hour(DateToFormat), "a", "p")
Case "dddd" ResultArray(I) = CCSDateConstants.Weekdays(Weekday(DateToFormat) - 1)
Case "mmmm" ResultArray(I) = CCSDateConstants.Months(Month(DateToFormat) - 1)
Case "yyyy" ResultArray(I) = Year(DateToFormat)
Case "AM/PM" ResultArray(I) = CCGetAMPM(Hour(DateToFormat), "AM", "PM")
Case "am/pm" ResultArray(I) = CCGetAMPM(Hour(DateToFormat), "am", "pm")
Case "LongDate" ResultArray(I) = FormatDateTime(DateToFormat, vbLongDate)
Case "LongTime" ResultArray(I) = FormatDateTime(DateToFormat, vbLongTime)
Case "ShortDate" ResultArray(I) = FormatDateTime(DateToFormat, vbShortDate)
Case "ShortTime" ResultArray(I) = FormatDateTime(DateToFormat, vbShortTime)
Case "GeneralDate" ResultArray(I) = FormatDateTime(DateToFormat, vbGeneralDate)
Case Else
If Left(FormatMask(I), 1) = "\" Then _
ResultArray(I) = Mid(FormatMask(I), 1) _
Else
ResultArray(I) = FormatMask(I)
End Select
Next
Result = Join(ResultArray, "")
End If
CCFormatDate = Result
End Function
'End CCFormatDate
'CCFormatBoolean @0-635596FD
Function CCFormatBoolean(BooleanValue, arrFormat)
Dim Result, TrueValue, FalseValue, EmptyValue
If IsEmpty(arrFormat) Then
Result = CStr(BooleanValue)
Else
TrueValue = arrFormat(0)
FalseValue = arrFormat(1)
EmptyValue = arrFormat(2)
If IsEmpty(BooleanValue) Then
Result = EmptyValue
Else
If BooleanValue Then _
Result = TrueValue _
Else _
Result = FalseValue
End If
End If
CCFormatBoolean = Result
End Function
'End CCFormatBoolean
'CCFormatNumber @0-6007EFEB
Function CCFormatNumber(NumberToFormat, FormatArray)
Dim IsNegative
Dim IsExtendedFormat, IsDecimalSeparator, DecimalSeparator, IsPeriodSeparator, PeriodSeparator
If IsEmpty(NumberToFormat) Then
CCFormatNumber = ""
Exit Function
End If
If IsArray(FormatArray) Then
IsExtendedFormat = FormatArray(0)
IsNegative = (NumberToFormat < 0)
NumberToFormat = ABS(NumberToFormat) * FormatArray(7)
If IsExtendedFormat Then ' Extended format
IsDecimalSeparator = FormatArray(1)
DecimalSeparator = FormatArray(2)
IsPeriodSeparator = FormatArray(3)
PeriodSeparator = FormatArray(4)
Dim BeforeDecimal, AfterDecimal
Dim ObligatoryBeforeDecimal, DigitsBeforeDecimal, ObligatoryAfterDecimal, DigitsAfterDecimal
Dim I, Z
BeforeDecimal = FormatArray(5)
AfterDecimal = FormatArray(6)
If IsArray(BeforeDecimal) Then
For I = 0 To UBound(BeforeDecimal)
If BeforeDecimal(I) = "0" Then
ObligatoryBeforeDecimal = ObligatoryBeforeDecimal + 1
DigitsBeforeDecimal = DigitsBeforeDecimal + 1
ElseIf BeforeDecimal(I) = "#" Then
DigitsBeforeDecimal = DigitsBeforeDecimal + 1
End If
Next
End If
If IsArray(AfterDecimal) Then
For I = 0 To UBound(AfterDecimal)
If AfterDecimal(I) = "0" Then
ObligatoryAfterDecimal = ObligatoryAfterDecimal + 1
DigitsAfterDecimal = DigitsAfterDecimal + 1
ElseIf AfterDecimal(I) = "#" Then
DigitsAfterDecimal = DigitsAfterDecimal + 1
End If
Next
End If
Dim NumDigitsAfterDecimal, Result, DefaultValue
If ObligatoryAfterDecimal = 0 And DigitsAfterDecimal = 1 Then
NumDigitsAfterDecimal = -1
ElseIf Not IsDecimalSeparator Then
NumDigitsAfterDecimal = 0
Else
NumDigitsAfterDecimal = DigitsAfterDecimal
End If
NumberToFormat = FormatNumber(NumberToFormat, DigitsAfterDecimal, False, False, False)
Dim DefaultDecimal : DefaultDecimal = Mid(FormatNumber(10001/10, 1, True, False, True), 6, 1)
Dim LeftPart, RightPart
If Not InStr(CStr(NumberToFormat), DefaultDecimal) = 0 Then
Dim NumberParts : NumberParts = Split(CStr(NumberToFormat), DefaultDecimal)
LeftPart = CStr(NumberParts(0))
RightPart = CStr(NumberParts(1))
Else
LeftPart = CStr(NumberToFormat)
End If
Dim J : J = Len(LeftPart)
If IsDecimalSeparator And DecimalSeparator = "" Then
DefaultValue = CStr(FormatNumber(10001/10, 1, True, False, True))
DecimalSeparator = Mid(DefaultValue, 6, 1)
End If
If IsPeriodSeparator And PeriodSeparator = "" Then
DefaultValue = CStr(FormatNumber(10001/10, 1, True, False, True))
PeriodSeparator = Mid(DefaultValue, 2, 1)
End If
If IsArray(BeforeDecimal) Then
Dim RankNumber : RankNumber = 0
For I = UBound(BeforeDecimal) To 0 Step -1
If BeforeDecimal(i) = "#" Or BeforeDecimal(i) = "0" Then
If DigitsBeforeDecimal = 1 And J > 1 Then
If Not IsPeriodSeparator Then
Result = Left(LeftPart, j) & Result
Else
For z = J To 1 Step -1
RankNumber = RankNumber + 1
If RankNumber Mod 3 = 1 And RankNumber - 3 > 0 Then
Result = Mid(LeftPart, z, 1) & PeriodSeparator & Result
Else
Result = Mid(LeftPart, z, 1) & Result
End If
Next
End If
ElseIf J > 0 Then
RankNumber = RankNumber + 1
If RankNumber Mod 3 = 1 And RankNumber - 3 > 0 And IsPeriodSeparator Then
Result = Mid(LeftPart, j, 1) & PeriodSeparator & Result
Else
Result = Mid(LeftPart, j, 1) & Result
End If
J = J - 1
ObligatoryBeforeDecimal = ObligatoryBeforeDecimal - 1
DigitsBeforeDecimal = DigitsBeforeDecimal - 1
Else
If ObligatoryBeforeDecimal > 0 Then
RankNumber = RankNumber + 1
If RankNumber Mod 3 = 1 And RankNumber - 3 > 0 And IsPeriodSeparator Then
Result = "0" & PeriodSeparator & Result
Else
Result = "0" & Result
End If
ObligatoryBeforeDecimal = ObligatoryBeforeDecimal - 1
DigitsBeforeDecimal = DigitsBeforeDecimal - 1
End If
End If
Else
BeforeDecimal(I) = Replace(BeforeDecimal(I), "##", "#")
BeforeDecimal(I) = Replace(BeforeDecimal(I), "00", "0")
Result = BeforeDecimal(I) & Result
End If
Next
End If
' Left part after decimal
Dim RightResult, IsRightResult : RightResult = "" : IsRightResult = False
If IsArray(AfterDecimal) Then
Dim IsZero : IsZero = True
For I = UBound(AfterDecimal) To 0 Step -1
If AfterDecimal(I) = "#" Or AfterDecimal(I) = "0" Then
If DigitsAfterDecimal > ObligatoryAfterDecimal Then
If Not Mid(RightPart, DigitsAfterDecimal, 1) = "0" Then IsZero = False
If Not IsZero Then
RightResult = Mid(RightPart, DigitsAfterDecimal, 1) & RightResult
IsRightResult = True
End If
DigitsAfterDecimal = DigitsAfterDecimal - 1
Else
RightResult = Mid(RightPart, DigitsAfterDecimal, 1) & RightResult
DigitsAfterDecimal = DigitsAfterDecimal - 1
IsRightResult = True
End If
Else
AfterDecimal(I) = Replace(AfterDecimal(I), "##", "#")
AfterDecimal(I) = Replace(AfterDecimal(I), "00", "0")
RightResult = AfterDecimal(I) & RightResult
End If
Next
End If
If IsRightResult Then Result = Result & DecimalSeparator
Result = Result & RightResult
If NOT FormatArray(10) AND IsNegative Then _
Result = "-" & Result
Else ' Simple format
If Not FormatArray(3) AND IsNegative Then _
Result = "-" & FormatArray(5) & FormatNumber(NumberToFormat, FormatArray(1), FormatArray(2), False, FormatArray(4)) & FormatArray(6) _
Else _
Result = FormatArray(5) & FormatNumber(NumberToFormat, FormatArray(1), FormatArray(2), False, FormatArray(4)) & FormatArray(6)
End If
If Not FormatArray(8) Then Result = Server.HTMLEncode(Result)
If Not CStr(FormatArray(9)) = "" Then _
Result = "" & Result & ""
Else
Result = CStr(NumberToFormat)
End If
CCFormatNumber = Result
End Function
'End CCFormatNumber
'CCParseBoolean @0-33711A62
Function CCParseBoolean(Value, FormatMask)
Dim Result
Result = Empty
If VarType(Value) = vbBoolean Then
Result = Value
Else
If IsEmpty(FormatMask) Then
Result = CBool(Value)
Else
If IsEmpty(Value) Then
If CStr(FormatMask(0)) = "null" Then _
Result = True
If CStr(FormatMask(1)) = "null" Then _
Result = False
Else
If CStr(Value) = CStr(FormatMask(0)) Then
Result = True
ElseIf CStr(Value) = CStr(FormatMask(1)) Then
Result = False
End If
End If
End If
End If
CCParseBoolean = Result
End Function
'End CCParseBoolean
'CCParseDate @0-E8152969
Function CCParseDate(ParsingDate, FormatMask)
Dim ResultDate, ResultDateArray(8)
Dim MaskPart, MaskLength, TokenLength
Dim IsError
Dim DatePosition, MaskPosition
Dim Delimiter, BeginDelimiter
Dim MonthNumber, MonthName, MonthArray
Dim DatePart
Dim IS_DATE_POS, YEAR_POS, MONTH_POS, DAY_POS, IS_TIME_POS, HOUR_POS, MINUTE_POS, SECOND_POS
IS_DATE_POS = 0 : YEAR_POS = 1 : MONTH_POS = 2 : DAY_POS = 3
IS_TIME_POS = 4 : HOUR_POS = 5 : MINUTE_POS = 6 : SECOND_POS = 7
If IsEmpty(FormatMask) Then
If CStr(ParsingDate) = "" Then _
ResultDate = Empty _
Else _
ResultDate = CDate(ParsingDate)
ElseIf (FormatMask(0) = "GeneralDate" Or FormatMask(0) = "LongDate" _
Or FormatMask(0) = "ShortDate" Or FormatMask(0) = "LongTime" _
Or FormatMask(0) = "ShortTime") And Not CStr(ParsingDate) = "" Then
ResultDate = CDate(ParsingDate)
ElseIf CStr(ParsingDate) = "" Then
ResultDate = Empty
Else
DatePosition = 1
MaskPosition = 0
MaskLength = UBound(FormatMask)
IsError = False
' Default date
ResultDateArray(IS_DATE_POS) = False
ResultDateArray(IS_TIME_POS) = False
ResultDateArray(YEAR_POS) = 0 : ResultDateArray(MONTH_POS) = 12 : ResultDateArray(DAY_POS) = 1
ResultDateArray(HOUR_POS) = 0 : ResultDateArray(MINUTE_POS) = 0 : ResultDateArray(SECOND_POS) = 0
While (MaskPosition <= MaskLength) AND NOT IsError
MaskPart = FormatMask(MaskPosition)
If CCSDateConstants.DateMasks.Exists(MaskPart) Then
TokenLength = CCSDateConstants.DateMasks(MaskPart)
If TokenLength > 0 Then
DatePart = Mid(ParsingDate, DatePosition, TokenLength)
DatePosition = DatePosition + TokenLength
Else
If MaskPosition < MaskLength Then
Delimiter = FormatMask(MaskPosition + 1)
BeginDelimiter = InStr(DatePosition, ParsingDate, Delimiter)
If BeginDelimiter = 0 Then
Err.Raise 4000, "ParseDate function: The number doesn't match the mask."
Else
DatePart = Mid(ParsingDate, DatePosition, BeginDelimiter - DatePosition)
DatePosition = BeginDelimiter
End If
Else
DatePart = Mid(ParsingDate, DatePosition)
End If
End If
Select Case MaskPart
Case "d", "dd"
ResultDateArray(DAY_POS) = CInt(DatePart)
ResultDateArray(IS_DATE_POS) = True
Case "m", "mm"
ResultDateArray(MONTH_POS) = CInt(DatePart)
ResultDateArray(IS_DATE_POS) = True
Case "mmm", "mmmm"
MonthNumber = 0
MonthName = UCase(DatePart)
If MaskPart = "mmm" Then _
MonthArray = CCSDateConstants.ShortMonths _
Else _
MonthArray = CCSDateConstants.Months
While MonthNumber < 11 AND UCase(MonthArray(MonthNumber)) <> MonthName
MonthNumber = MonthNumber + 1
Wend
If MonthNumber = 11 Then
If UCase(MonthArray(11)) <> MonthName Then _
Err.Raise 4000, "ParseDate function: The number doesn't match the mask."
End If
ResultDateArray(MONTH_POS) = MonthNumber + 1
ResultDateArray(IS_DATE_POS) = True
Case "yy", "yyyy"
ResultDateArray(YEAR_POS) = CInt(DatePart)
ResultDateArray(IS_DATE_POS) = True
Case "h", "hh"
If CInt(DatePart) = 12 Then _
ResultDateArray(HOUR_POS) = 0 _
Else _
ResultDateArray(HOUR_POS) = CInt(DatePart)
ResultDateArray(IS_TIME_POS) = True
Case "H", "HH"
ResultDateArray(HOUR_POS) = CInt(DatePart)
ResultDateArray(IS_TIME_POS) = True
Case "n", "nn"
ResultDateArray(MINUTE_POS) = CInt(DatePart)
ResultDateArray(IS_TIME_POS) = True
Case "s", "ss"
ResultDateArray(SECOND_POS) = CInt(DatePart)
ResultDateArray(IS_TIME_POS) = True
Case "am/pm", "a/p", "AM/PM", "A/P"
If Left(LCase(DatePart), 1) = "p" Then
ResultDateArray(HOUR_POS) = ResultDateArray(HOUR_POS) + 12
ElseIf Left(LCase(DatePart), 1) = "a" Then
ResultDateArray(HOUR_POS) = ResultDateArray(HOUR_POS)
End If
ResultDateArray(IS_TIME_POS) = True
Case "w", "q","S"
' Do Nothing
End Select
Else
DatePosition = DatePosition + Len(FormatMask(MaskPosition))
End If
MaskPosition = MaskPosition + 1
Wend
If ResultDateArray(IS_TIME_POS) AND ResultDateArray(IS_TIME_POS) Then
ResultDate = CStr(DateSerial(ResultDateArray(YEAR_POS), ResultDateArray(MONTH_POS), ResultDateArray(DAY_POS))) & " " & _
CStr(TimeSerial(ResultDateArray(HOUR_POS), ResultDateArray(MINUTE_POS), ResultDateArray(SECOND_POS)))
ElseIf ResultDateArray(IS_TIME_POS) Then
ResultDate = TimeSerial(ResultDateArray(HOUR_POS), ResultDateArray(MINUTE_POS), ResultDateArray(SECOND_POS))
ElseIf ResultDateArray(IS_DATE_POS) Then
ResultDate = DateSerial(ResultDateArray(YEAR_POS), ResultDateArray(MONTH_POS), ResultDateArray(DAY_POS))
End If
End If
CCParseDate = ResultDate
End Function
'End CCParseDate
'CCParseNumber @0-BDE16F1E
Function CCParseNumber(NumberValue, FormatArray, DataType)
Dim Result, NumberValueType
NumberValueType = VarType(NumberValue)
If NumberValueType = vbInteger OR NumberValueType = vbLong _
OR NumberValueType = vbSingle OR NumberValueType = vbSingle _
OR NumberValueType = vbCurrency OR NumberValueType = vbDecimal _
OR NumberValueType = vbByte Then
If DataType = ccsInteger Then
Result = CLng(NumberValue)
ElseIf DataType = ccsFloat Then
Result = CDbl(NumberValue)
End If
Else
If Not CStr(NumberValue) = "" Then
Dim DefaultValue, DefaultDecimal
Dim DecimalSeparator, PeriodSeparator
DecimalSeparator = "" : PeriodSeparator = ""
If IsArray(FormatArray) Then
If FormatArray(0) Then
DecimalSeparator = FormatArray(2)
PeriodSeparator = FormatArray(4)
End If
End If
If Not CStr(DecimalSeparator) = "" Then
DefaultValue = CStr(FormatNumber(10001/10, 1, True, False, True))
DefaultDecimal = Mid(DefaultValue, 6, 1)
NumberValue = Replace(NumberValue, DecimalSeparator, DefaultDecimal)
End If
If Not CStr(PeriodSeparator) = "" Then NumberValue = Replace(NumberValue, PeriodSeparator, "")
If DataType = ccsInteger Then
Result = CLng(NumberValue)
ElseIf DataType = ccsFloat Then
Result = CDbl(NumberValue)
End If
Else
Result = Empty
End If
End If
CCParseNumber = Result
End Function
'End CCParseNumber
'CCParseInteger @0-42815927
Function CCParseInteger(NumberValue, FormatArray)
CCParseInteger = CCParseNumber(NumberValue, FormatArray, ccsInteger)
End Function
'End CCParseInteger
'CCParseFloat @0-56667DF0
Function CCParseFloat(NumberValue, FormatArray)
CCParseFloat = CCParseNumber(NumberValue, FormatArray, ccsFloat)
End Function
'End CCParseFloat
'CCValidateDate @0-3A410B19
Function CCValidateDate(ValidatingDate, FormatMask)
Dim MaskPosition, I, Result, OneChar, IsSeparator
Dim RegExpPattern, RegExpObject, Matches
Dim ParsedTestDate, FormattedTestDate
IsSeparator = False
If ValidatingDate = "" OR IsEmpty(ValidatingDate) Then
Result = True
ElseIf IsEmpty(FormatMask) Then
Result = IsDate(ValidatingDate)
ElseIf FormatMask(0) = "GeneralDate" Or FormatMask(0) = "LongDate" _
Or FormatMask(0) = "ShortDate" Or FormatMask(0) = "LongTime" _
Or FormatMask(0) = "ShortTime" Then
Result = IsDate(ValidatingDate)
Else
ParsedTestDate = CCParseDate(ValidatingDate, FormatMask)
FormattedTestDate = CCFormatDate(ParsedTestDate, FormatMask)
Result = FormattedTestDate = ValidatingDate
End If
CCValidateDate = Result
End Function
'End CCValidateDate
'CCValidateNumber @0-08089509
Function CCValidateNumber(NumberValue, FormatArray)
Dim Result, NumberValueType
NumberValueType = VarType(NumberValue)
If NumberValueType = vbInteger OR NumberValueType = vbLong _
OR NumberValueType = vbSingle OR NumberValueType = vbSingle _
OR NumberValueType = vbCurrency OR NumberValueType = vbDecimal _
OR NumberValueType = vbByte Then
Result = True
Else
If Not CStr(NumberValue) = "" Then
Dim DefaultValue, DefaultDecimal
Dim DecimalSeparator, PeriodSeparator
DecimalSeparator = "" : PeriodSeparator = ""
If IsArray(FormatArray) Then
If FormatArray(0) Then
DecimalSeparator = FormatArray(2)
PeriodSeparator = FormatArray(4)
End If
End If
If Not CStr(DecimalSeparator) = "" Then
DefaultValue = CStr(FormatNumber(10001/10, 1, True, False, True))
DefaultDecimal = Mid(DefaultValue, 6, 1)
NumberValue = Replace(NumberValue, DecimalSeparator, DefaultDecimal)
End If
If Not CStr(PeriodSeparator) = "" Then NumberValue = Replace(NumberValue, PeriodSeparator, "")
Result = IsNumeric(NumberValue)
Else
Result = True
End If
End If
CCValidateNumber = Result
End Function
'End CCValidateNumber
'CCValidateBoolean @0-B8DE2060
Function CCValidateBoolean(Value, FormatMask)
Dim Result: Result = False
If VarType(Value) = vbBoolean Then
Result = True
Else
If IsEmpty(FormatMask) Then
On Error Resume Next
Result = CBool(Value)
Result = Not(Err > 0)
Else
If IsEmpty(Value) Or CStr(Value) = "" Then
Result = (CStr(FormatMask(0)) = "null") Or (CStr(FormatMask(0)) = "Undefined") Or (CStr(FormatMask(0)) = "")
Result = Result Or (CStr(FormatMask(1)) = "null") Or (CStr(FormatMask(1)) = "Undefined") Or (CStr(FormatMask(1)) = "")
If UBound(FormatMask) = 2 Then _
Result = Result Or (CStr(FormatMask(2)) = "null") Or (CStr(FormatMask(2)) = "Undefined") Or (CStr(FormatMask(2)) = "")
Else
Result = (CStr(Value) = CStr(FormatMask(0))) Or (CStr(Value) = CStr(FormatMask(1)))
If UBound(FormatMask) = 2 Then _
Result = Result Or (CStr(Value) = CStr(FormatMask(2)))
End If
End If
End If
CCValidateBoolean = Result
End Function
'End CCValidateBoolean
'CCAddParam @0-6D59DAA5
Function CCAddParam(QueryString, ParameterName, ParameterValue)
Dim Result
Result = Replace("&" & QueryString, "&" & ParameterName & "=" & Server.URLEncode(Request.QueryString(ParameterName)), "")
Result = Result & "&" & ParameterName & "=" & Server.URLEncode(ParameterValue)
Result = Replace(Result, "&&", "&")
If Left(Result, 1) = "&" Then Result = Mid(Result, 2)
CCAddParam = Result
End Function
'End CCAddParam
'CCRemoveParam @0-64B4FAAF
Function CCRemoveParam(QueryString, ParameterName)
Dim Result
Result = Replace(QueryString, ParameterName & "=" & Server.URLEncode(Request.QueryString(ParameterName)), "")
Result = Replace(Result, "&&", "&")
If Left(Result, 1) = "&" Then Result = Mid(Result, 2)
CCRemoveParam = Result
End Function
'End CCRemoveParam
'CCRegExpTest @0-9EAA5A2D
Function CCRegExpTest(TestValue, RegExpMask, IgnoreCase, GlobalTest)
Dim Result
If Not CStr(TestValue) = "" Then
Dim RegExpObject
Set RegExpObject = New RegExp
RegExpObject.Pattern = RegExpMask
RegExpObject.IgnoreCase = IgnoreCase
RegExpObject.Global = GlobalTest
Result = RegExpObject.Test(CStr(TestValue))
Set RegExpObject = Nothing
Else
Result = True
End If
CCRegExpTest = Result
End Function
'End CCRegExpTest
'CCRegExpTest @0-4BE3AE1D
Sub CheckSSL()
If Not UCase(Request.ServerVariables("HTTPS")) = "ON" Then
Response.Write "SSL connection error. This page can be accessed only via secured connection."
Response.End
End If
End Sub
'End CCRegExpTest
%>