%
'File Description @0-AE1083C9
'======================================================
'
' This file contains the following classes:
' Class clsSQLParameters
' Class clsSQLParameter
' Class clsFields
' Class clsControls
' Class clsControl
' Class clsField
' Class clsButton
' Class clsFileUpload
' Class clsDatePicker
' Class clsListControl
' Class clsErrors
' Class clsEmptyDataSource
' Class clsDataSource
' Class clsCommand
' Class clsStringBuffer
' Class clsConverter
'
'======================================================
'End File Description
'Constant List @0-52D70043
' ------- Controls ---------------
Const ccsLabel = 00001
Const ccsLink = 00002
Const ccsTextBox = 00003
Const ccsTextArea = 00004
Const ccsListBox = 00005
Const ccsRadioButton = 00006
Const ccsButton = 00007
Const ccsCheckBox = 00008
Const ccsImage = 00009
Const ccsImageLink = 00010
Const ccsHidden = 00011
Const ccsCheckBoxList = 00012
Const ccsDatePicker = 00013
Dim ccsControlTypes(13)
ccsControlTypes(ccsLabel) = "Label"
ccsControlTypes(ccsLink) = "Link"
ccsControlTypes(ccsTextBox) = "TextBox"
ccsControlTypes(ccsTextArea) = "TextArea"
ccsControlTypes(ccsListBox) = "ListBox"
ccsControlTypes(ccsRadioButton) = "RadioButton"
ccsControlTypes(ccsButton) = "Button"
ccsControlTypes(ccsCheckBox) = "CheckBox"
ccsControlTypes(ccsImage) = "Image"
ccsControlTypes(ccsImageLink) = "ImageLink"
ccsControlTypes(ccsHidden) = "Hidden"
ccsControlTypes(ccsCheckBoxList) = "CheckBoxList"
ccsControlTypes(ccsDatePicker) = "DatePicker"
' ------- Operators --------------
Const opEqual = 00001
Const opNotEqual = 00002
Const opLessThan = 00003
Const opLessThanOrEqual = 00004
Const opGreaterThan = 00005
Const opGreaterThanOrEqual = 00006
Const opBeginsWith = 00007
Const opNotBeginsWith = 00008
Const opEndsWith = 00009
Const opNotEndsWith = 00010
Const opContains = 00011
Const opNotContains = 00012
Const opIsNull = 00013
Const opNotNull = 00014
' ------- Datasource types -------
Const dsTable = 00001
Const dsSQL = 00002
Const dsProcedure = 00003
Const dsListOfValues = 00004
Const dsEmpty = 00005
' ------- Command types -------
Const cmdOpen = 00001
Const cmdExec = 00002
' ------- Parse types ------------
Const ccsParseAccumulate = True
Const ccsParseOverwrite = False
' ------- Listbox populating types ------------
Const ccsJoins = 0
Const ccsStringConcats = 1
' ------- CheckBox states --------
Const ccsChecked = True
Const ccsUnchecked = False
'End Constant List
'clsSQLParameters Class @0-CE6B1D13
Class clsSQLParameters
Public Connection
Public Criterion()
Public AssembledWhere
Public ParameterSources
Public Errors
Public DataSource
Public ParametersList
Private Sub Class_Initialize()
ReDim Criterion(100)
Set ParametersList = Server.CreateObject("Scripting.Dictionary")
Set DataSource = Nothing
End Sub
Private Sub Class_Terminate()
Set ParametersList = Nothing
End Sub
Public Default Property Get Parameters(Name)
Set Parameters = ParametersList(Name)
End Property
Public Property Set Parameters(Name, NewParameter)
Set ParametersList(Name) = NewParameter
End Property
Property Get Count()
Count = ParametersList.Count
End Property
Function AddParameter(ID, ParameterSource, DataType, Format, DBFormat, DefaultValue, UseIsNull)
Dim SQLParameter
Set SQLParameter = New clsSQLParameter
With SQLParameter
Set .Connection = Connection
.DataType = DataType
.Format = Format
.DBFormat = DBFormat
.Caption = ParameterSource
.DefaultValue = DefaultValue
.UseIsNull = UseIsNull
Set .DataSource = DataSource
If IsObject(ParameterSources) Then
If IsEmpty(DefaultValue) Or ((DataType <> ccsText And DataType <> ccsMemo) And CStr(DefaultValue) = "") Then
.Text = ParameterSources(ParameterSource)
Else
If IsEmpty(ParameterSources(ParameterSource)) Or ((DataType <> ccsText And DataType <> ccsMemo) And ParameterSources(ParameterSource) = "") Then
.Text = DefaultValue
Else
.Text = ParameterSources(ParameterSource)
End If
End If
End If
End With
Set ParametersList(ID) = SQLParameter
Set SQLParameter = Nothing
End Function
Function getParamByID(ID)
Set getParamByID = ParametersList(ID)
End Function
Property Get AllParamsSet()
Dim ParametersItems, I, Result
Result = True
I = 0
ParametersItems = ParametersList.Items
While Result AND (I <= UBound(ParametersItems))
Result = (NOT IsEmpty(ParametersItems(I).Value)) OR (IsEmpty(ParametersItems(I).Value) AND ParametersItems(I).UseIsNull)
I = I + 1
Wend
AllParamsSet = Result
End Property
Function GetError()
Dim ParametersItems, I, Result
ParametersItems = ParametersList.Items
For I = 0 To UBound(ParametersItems)
Result = Result & ParametersItems(I).Errors.ToString
Next
GetError = Result
End Function
Function opAND(Brackets, LeftPart, RightPart)
Dim Result
If NOT IsEmpty(LeftPart) Then
If NOT IsEmpty(RightPart) Then
Result = LeftPart & " and " & RightPart
Else
Result = LeftPart
End If
Else
If NOT IsEmpty(RightPart) Then
Result = RightPart
End If
End If
If Brackets And NOT IsEmpty(Result) Then _
Result = " (" & Result & ") "
opAND = Result
End Function
Function opOR(Brackets, LeftPart, RightPart)
Dim Result
If NOT IsEmpty(LeftPart) Then
If NOT IsEmpty(RightPart) Then
Result = LeftPart & " or " & RightPart
Else
Result = LeftPart
End If
Else
If NOT IsEmpty(RightPart) Then
Result = RightPart
End If
End If
If Brackets And NOT IsEmpty(Result) Then _
If Brackets Then Result = " (" & Result & ") "
opOR = Result
End Function
Function Operation(Operator, Brackets, FieldName, Parameter)
If CStr(Parameter.Text) <> "" Then
Dim Result
Dim Value, SQLValue
Value = Parameter.SQLText
SQLValue = Connection.ToSQL(Value, Parameter.DataType)
Select Case Operator
Case opEqual
Result = FieldName & " = " & SQLValue
Case opNotEqual
Result = FieldName & " <> " & SQLValue
Case opLessThan
Result = FieldName & " < " & SQLValue
Case opLessThanOrEqual
Result = FieldName & " <= " & SQLValue
Case opGreaterThan
Result = FieldName & " > " & SQLValue
Case opGreaterThanOrEqual
Result = FieldName & " >= " & SQLValue
Case opBeginsWith
Result = FieldName & " like '" & Value & "%'"
Case opNotBeginsWith
Result = FieldName & " not like '" & Value & "%'"
Case opEndsWith
Result = FieldName & " like '%" & Value & "'"
Case opNotEndsWith
Result = FieldName & " not like '%" & Value & "'"
Case opContains
Result = FieldName & " like '%" & Value & "%'"
Case opNotContains
Result = FieldName & " not like '%" & Value & "%'"
Case opIsNull
Result = FieldName & " is null"
Case opNotNull
Result = FieldName & " is not null"
End Select
Operation = Result
Else
If Parameter.UseIsNull Then
Select Case Operator
Case opNotEqual, opNotBeginsWith, opNotEndsWith, opNotContains, opNotNull
Result = FieldName & " is not null"
Case Else
Result = FieldName & " is null"
End Select
Operation = Result
Else
Operation = Empty
End If
End If
End Function
End Class
'End clsSQLParameters Class
'clsSQLParameter Class @0-660A24C2
Class clsSQLParameter
Public Errors
Public DataType
Public Format
Public DBFormat
Public Caption
Public Connection
Public DataSource
Public DefaultValue
Public UseIsNull
Private VarValue
Private SQLTextValue
Private TextValue
Private Sub Class_Initialize()
VarValue = Empty
SQLTextValue = Empty
TextValue = Empty
UseIsNull = False
DataType = ccsText
Set Errors = New clsErrors
End Sub
Private Sub Class_Terminate()
Set Errors = Nothing
End Sub
Function GetParsedValue(ParsingValue, MaskFormat)
Dim Result
If Not IsEmpty(ParsingValue) Then
Select Case DataType
Case ccsDate
If VarType(ParsingValue) = vbDate Then
Result = ParsingValue
ElseIf CCValidateDate(ParsingValue, MaskFormat) Then
Result = CCParseDate(ParsingValue, MaskFormat)
Else
If IsArray(Format) Then
PrintDBError "", "", "Der Wert im Feld " & Caption & " ist nicht gültig. Benutzen Sie folgendes Format: " & Join(Format, "") & "."
Else
PrintDBError "", "", "Im Feld " & Caption & " wurde kein gültiger Wert eingegeben."
End If
End If
Case ccsBoolean
Result = CCParseBoolean(ParsingValue, MaskFormat)
Case ccsInteger
If CCValidateNumber(ParsingValue, MaskFormat) Then
Result = CCParseInteger(ParsingValue, MaskFormat)
Else
PrintDBError "", "", "Im Feld " & Caption & " wurde kein gültiger Wert eingegeben."
End If
Case ccsFloat
If CCValidateNumber(ParsingValue, MaskFormat) Then
Result = CCParseFloat(ParsingValue, MaskFormat)
Else
PrintDBError "", "", "Im Feld " & Caption & " wurde kein gültiger Wert eingegeben."
End If
Case ccsText, ccsMemo
Result = CStr(ParsingValue)
End Select
End If
GetParsedValue = Result
End Function
Function GetFormattedValue(MaskFormat)
Dim Result, Value
If IsEmpty(VarValue) Then
Value = DefaultValue
Else
Value = VarValue
End If
Select Case DataType
Case ccsDate
Result = CCFormatDate(Value, MaskFormat)
Case ccsBoolean
Result = CCFormatBoolean(Value, MaskFormat)
Case ccsInteger, ccsFloat
Result = CCFormatNumber(Value, MaskFormat)
Case ccsText, ccsMemo
Result = CStr(Value)
If CStr(Result) <> "" Then Result = Connection.EscapeChars(Result)
End Select
GetFormattedValue = Result
End Function
Property Let Value(NewValue)
VarValue = Empty
SQLTextValue = Empty
TextValue = Empty
If NOT IsEmpty(NewValue) And Not (NewValue="") Then
Select Case DataType
Case ccsDate
VarValue = CDate(NewValue)
Case ccsBoolean
VarValue = CBool(NewValue)
Case ccsInteger
VarValue = CLng(NewValue)
Case ccsFloat
VarValue = CDbl(NewValue)
Case ccsText, ccsMemo
VarValue = CStr(NewValue)
End Select
End If
End Property
Property Get Value()
If IsEmpty(VarValue) Then
Value = DefaultValue
Else
Value = VarValue
End If
End Property
Property Let Text(NewText)
If Not IsEmpty(NewText) Then
SQLTextValue = Empty
TextValue = NewText
VarValue = GetParsedValue(TextValue, Format)
End If
End Property
Property Get Text()
If IsEmpty(TextValue) Then TextValue = GetFormattedValue(Format)
Text = TextValue
End Property
Property Let SQLText(varNewSQLText)
SQLTextValue = varNewSQLText
End Property
Property Get SQLText()
If IsEmpty(SQLTextValue) Then
SQLTextValue = GetFormattedValue(DBFormat)
End If
SQLText = SQLTextValue
End Property
End Class
'End clsSQLParameter Class
'clsFields Class @0-791D3D1C
Class clsFields
Private objFields
Private Items
Private Counter
Private Sub Class_Initialize()
Set objFields = CreateObject("Scripting.Dictionary")
End Sub
Sub AddFields(Fields) ' Add new objects to Object array
Dim I
If IsArray(Fields) Then
For I = LBound(Fields) To UBound(Fields)
Set objFields(Fields(I).Name) = Fields(I)
Next
End If
End Sub
Public Default Property Get Item(Name)
Set Item = objFields(Name)
End Property
Sub InitEnum()
Items = objFields.Items
Counter = 0
End Sub
Function NextItem()
Set NextItem = Items(Counter)
Counter = Counter + 1
End Function
Function EndOfEnum()
EndOfEnum = (Counter > UBound(Items))
End Function
Function Exists(Name)
Exists = objFields.Exists(Name)
End Function
End Class
'End clsFields Class
'CCCreateCollection Function @0-61899D71
Function CCCreateCollection(Block, TargetBlock, Accumulate, Controls)
Dim Collection
Set Collection = New clsControls
With Collection
Set .Block = Block
If NOT IsNull(TargetBlock) Then
Set .TargetBlock = TargetBlock
End If
.Accumulate = Accumulate
.AddControls Controls
End With
Set CCCreateCollection = Collection
End Function
'End CCCreateCollection Function
'clsControls Class @0-2F2957A8
Class clsControls
Private Objects ' Dictionary object
Private CCSEventResult
Private EnumData
Private Counter
Public Block
Public Accumulate
Private objTargetBlock
Private isSetTargetBlock
Private mVisible
Private Sub Class_Initialize()
Set Objects = Server.CreateObject("Scripting.Dictionary")
mVisible = True
End Sub
Private Sub Class_Terminate()
Set Objects = Nothing
End Sub
Sub AddControls(Controls) ' Add new objects to Object array
Dim ArraySize, NumberControls, I
If IsArray(Controls) Then
NumberControls = UBound(Controls)
ArraySize = Objects.Count
For i = ArraySize To ArraySize + NumberControls
Objects.Add i,Controls(I)
Next
End If
End Sub
Sub AddControl(Control) ' Add a new object to Object array
If TypeName(Control) = "clsControls" Then
Objects.Add Objects.Count, Control
Else
Objects.Add Control.Name, Control
End If
End Sub
Property Get Items(ItemName)
If Objects.Exists(ItemName) Then
Set Items = Objects(ItemName)
Else
Set Items = Nothing
End If
End Property
Property Let Items(ItemName, NewItem)
If Objects.Exists(ItemName) Then
Objects(ItemName) = NewItem
Else
Objects.Add ItemName, NewItem
End If
End Property
Function GetItemByName(ItemName)
Dim Element
For Each Element In Objects
If Objects.Item(Element).Name = ItemName Then
Set GetItemByName = Objects.Item(Element)
Exit Function
End If
Next
Set GetItemByName = Nothing
End Function
Sub Show()
Dim Element, Obj
If NOT mVisible Then Exit Sub
For Each Element In Objects
Set Obj = Objects.Item(element)
If TypeName(Obj) = "clsControls" Then
Obj.Show
Else
Obj.Show Block
End If
Next
If Not IsEmpty(Accumulate) Then
If isSetTargetBlock Then
Block.ParseTo Accumulate, objTargetBlock
Else
Block.Parse Accumulate
End If
End If
End Sub
Sub Validate()
Dim Element
For Each Element In Objects
Objects.Item(Element).Validate
Next
End Sub
Function isValid()
Dim Element
For Each Element In Objects
If Objects.Item(Element).Errors.Count > 0 Then
isValid = False
Exit Function
End If
Next
isValid = True
End Function
Function GetErrors()
Dim Errors, Element
For Each Element In Objects
Errors = Errors & Objects.Item(Element).Errors.ToString
Next
GetErrors = Errors
End Function
Property Set TargetBlock(NewBlock)
isSetTargetBlock = True
Set objTargetBlock = NewBlock
End Property
Sub InitEnum()
EnumData = Objects.Items
Counter = 0
End Sub
Function NextItem()
Set NextItem = EnumData(Counter)
Counter = Counter + 1
End Function
Function EndOfEnum()
EndOfEnum = (Counter > UBound(EnumData))
End Function
Property Let Visible(newValue)
mVisible = CBool(newValue)
End Property
Property Get Visible()
Visible = mVisible
End Property
End Class
'End clsControls Class
'CCCreateControl Function @0-706BB4D6
Function CCCreateControl(ControlType, Name, Caption, DataType, Format, InitValue)
Dim Control
Set Control = New clsControl
With Control
.ControlType = ControlType
.Name = Name
.BlockName = ccsControlTypes(ControlType) & " " & Name
.ControlTypeName = ccsControlTypes(ControlType)
.Caption = Caption
.DataType = DataType
.Format = Format
If NOT IsEmpty(InitValue) Then
If ControlType = ccsCheckBox Then
.State = True
Else
.Text = InitValue
End If
End If
End With
Set CCCreateControl = Control
End Function
'End CCCreateControl Function
'clsControl Class @0-BD2FDB2D
Class clsControl
Public Errors
Public DataType
Public Format
Public DBFormat
Public Caption
Public ControlType
Public ControlTypeName
Public Name
Public BlockName
Public ExternalName
Public HTML
Public Required
Public CheckedValue
Public UncheckedValue
Public State
Public Visible
Public TemplateBlock
Public Parameters
Private mPage
Private VarValue
Private TextValue
Public CCSEvents
Private CCSEventResult
Private Sub Class_Initialize()
VarValue = Empty
TextValue = Empty
Visible = True
ExternalName = Empty
DataType = ccsText
HTML = False
Required = False
Set Errors = New clsErrors
Set CCSEvents = CreateObject("Scripting.Dictionary")
Parameters = ""
End Sub
Private Sub Class_Terminate()
Set Errors = Nothing
End Sub
Function Validate()
If Required And CStr(VarValue) = "" And Errors.Count = 0 Then
Errors.addError(CCSRunTimeMessages.GetMessage("RequiredField", Array("FieldName", Caption)))
End If
Validate = CCRaiseEvent(CCSEvents, "OnValidate", Me)
End Function
Function GetParsedValue(ParsingValue, MaskFormat)
Dim Result
Result = CCSConverter.StringToType(DataType, ParsingValue, MaskFormat)
If CCSConverter.ParseError Then
If DataType = ccsDate AND (IsArray(Format) OR IsArray(CCSConverter.DateFormat)) Then
If IsArray(Format) Then _
Errors.addError(CCSRunTimeMessages.GetMessage("IncorrectFormat", Array("FieldName", Caption, "Format", Join(Format, "")))) _
Else _
Errors.addError(CCSRunTimeMessages.GetMessage("IncorrectFormat", Array("FieldName", Caption, "Format", Join(CCSConverter.DateFormat, ""))))
Else
Errors.addError(CCSRunTimeMessages.GetMessage("IncorrectValue", Array("FieldName", Caption)))
End If
End If
GetParsedValue = Result
End Function
Property Get Link()
Dim Result
If Parameters = "" Then
Result = mPage
Else
Result = mPage & "?" & Parameters
End If
Link = Result
End Property
Property Let Link(newLink)
Dim parsedLink
If CStr(newLink) = "" Then
mPage = ""
Parameters = ""
Else
parsedLink = Split(newLink, "?")
mPage = parsedLink(0)
If UBound(parsedLink) = 1 Then
Parameters = parsedLink(1)
Else
Parameters = ""
End If
End If
End Property
Property Get Page()
Page = mPage
End Property
Property Let Page(newPage)
mPage = newPage
End Property
Function GetFormattedValue(MaskFormat)
GetFormattedValue = CCSConverter.TypeToString(DataType, VarValue, MaskFormat)
End Function
Sub Show(Template)
Dim NeedShow, sTmpValue
Set TemplateBlock = Template.Block(ControlTypeName & " " & Name)
If TemplateBlock Is Nothing Then
Set TemplateBlock = Template
NeedShow = False
Else
NeedShow = True
TemplateBlock.HTML = ""
End If
CCSEventResult = CCRaiseEvent(CCSEvents, "BeforeShow", Me)
If NOT Visible Then
TemplateBlock.Variable(Name)=""
Exit Sub
End If
If IsEmpty(ExternalName) Then
TemplateBlock.Variable(Name & "_Name") = Name
Else
TemplateBlock.Variable(Name & "_Name") = ExternalName
End If
If IsEmpty(TextValue) Then
TextValue = GetFormattedValue(Format)
End If
Select Case ControlType
Case ccsLabel, ccsTextBox, ccsTextArea, ccsHidden
If HTML Then
TemplateBlock.Variable(Name) = TextValue
Else
sTmpValue = Server.HTMLEncode(TextValue)
If ControlType = ccsLabel Then
sTmpValue = Replace(sTmpValue, vbCrLf, " ")
End If
TemplateBlock.Variable(Name) = sTmpValue
End If
Case ccsImage
sTmpValue = Server.HTMLEncode(TextValue)
If ControlType = ccsLabel Then
sTmpValue = Replace(sTmpValue, vbCrLf, " ")
End If
TemplateBlock.Variable(Name) = sTmpValue
Case ccsLink
If HTML Then
TemplateBlock.Variable(Name) = TextValue
Else
TemplateBlock.Variable(Name) = Replace(Server.HTMLEncode(TextValue), vbCrLf, " ")
End If
TemplateBlock.Variable(Name & "_Src") = Me.Link
Case ccsImageLink
TemplateBlock.Variable(Name & "_Src") = Server.HTMLEncode(TextValue)
TemplateBlock.Variable(Name) = Me.Link
Case ccsCheckBox
If State Then
TemplateBlock.Variable(Name) = "CHECKED"
Else
TemplateBlock.Variable(Name) = ""
End If
End Select
If NeedShow Then TemplateBlock.Show
Set TemplateBlock = Nothing
End Sub
Property Let Value(NewValue)
VarValue = Empty
TextValue = Empty
VarValue = CCSConverter.VBSConvert(DataType, NewValue)
If ControlType = ccsCheckBox Then
If DataType = ccsBoolean Then
If IsEmpty(NewValue) Or (NewValue="") Then
State = False
Else
State = VarValue
End If
Else
if DataType = ccsDate Then
State = (VarValue = CDate(CheckedValue))
Else
State = (VarValue = CheckedValue)
End if
End If
End If
End Property
Property Get Value()
If ControlType = ccsCheckBox Then
If IsEmpty(State) Then
Value = UncheckedValue
Else
Value = IIf(State, CheckedValue, UncheckedValue)
End If
Else
Value = VarValue
End If
End Property
Property Let Text(NewText)
VarValue = Empty
TextValue = NewText
If ControlType = ccsCheckBox Then
VarValue = IIf(IsEmpty(NewText), UncheckedValue, CheckedValue)
State = (VarValue = CheckedValue)
Else
VarValue = GetParsedValue(TextValue, Format)
End If
End Property
Property Get Text()
If IsEmpty(TextValue) Then
TextValue = GetFormattedValue(Format)
End If
Text = TextValue
End Property
End Class
'End clsControl Class
'CCCreateField Function @0-A187BD87
Function CCCreateField(Name, DBFieldName, DataType, DBFormat, DataSource)
Dim Field
Set Field = New clsField
With Field
.Name = Name
.DBFieldName = DBFieldName
.DataType = DataType
.DBFormat = DBFormat
Set .DataSource = DataSource
End With
Set CCCreateField = Field
End Function
'End CCCreateField Function
'clsField Class @0-AEE3D759
Class clsField
Public DataType
Public DBFormat
Public Name
Public DBFieldName
Public Errors
Private mDataSource
Private mConverter
Private mValue
Private mSQLText
Private Sub Class_Initialize()
mValue = Empty
mSQLText = Empty
DataType = ccsText
Set Errors = New clsErrors
End Sub
Private Sub Class_Terminate()
Set Errors = Nothing
End Sub
Public Function GetParsedValue(ParsingValue, MaskFormat)
Dim Result, ValueType
Result = Empty
If NOT IsEmpty(ParsingValue) Then
ValueType = VarType(ParsingValue)
If ValueType = vbString Or (DataType=ccsBoolean And (ValueType>=2 And ValueType<=5)) Then
Result = mConverter.StringToType(DataType, ParsingValue, MaskFormat)
Else
Result = mConverter.VBSConvert(DataType, ParsingValue)
End If
If mConverter.ParseError Then
Errors.addError(CCSRunTimeMessages.GetMessage("IncorrectValue", Array("FieldName", Name)))
End If
End If
GetParsedValue = Result
End Function
Public Function GetFormattedValue(MaskFormat)
Dim Result
Result = CCSConverter.TypeToString(DataType, mValue, MaskFormat)
Select Case DataType
Case ccsText, ccsMemo
If CStr(Result) <> "" Then Result = mDataSource.DataSource.Connection.EscapeChars(Result)
End Select
GetFormattedValue = Result
End Function
Public Property Let Value(vData)
mSQLText = Empty
mValue = mConverter.VBSConvert(DataType, vData)
End Property
Public Default Property Get Value()
Dim RS, Result, ResultType
Result = mValue
If IsObject(mDataSource.Recordset) Then
Set RS = mDataSource.Recordset
If RS.State = adStateOpen Then
If NOT RS.EOF Then _
Result = CCGetValue(RS, DBFieldName)
End If
Result = GetParsedValue(Result, DBFormat)
End If
Value = Result
End Property
Public Property Let SQLText(vData)
mSQLText = vData
End Property
Public Property Get SQLText()
If IsEmpty(mSQLText) Then
mSQLText = GetFormattedValue(DBFormat)
End If
SQLText = mSQLText
End Property
Public Property Set DataSource(oRef)
Set mDataSource = oRef
If IsObject(mDataSource.Connection) Then
Set mConverter = mDataSource.Connection.Converter
Else
Set mConverter = CCSConverter
End If
End Property
Public Property Get DataSource()
Set DataSource = mDataSource
End Property
End Class
'End clsField Class
'clsFileElement Class @0-CBEFE57E
Class clsFileElement
Private mvarName
Private mvarUploadObject
Private mvarFileObject
Private mvarSize
Private mvarFileName
Private Sub Class_Initialize()
Set mvarUploadObject = Nothing
Set mvarFileObject = Nothing
mvarFileName = ""
mvarSize = 0
End Sub
Private Sub Class_Terminate()
Set mvarUploadObject = Nothing
Set mvarFileObject = Nothing
End Sub
Public Property Set UploadObject(NewObject)
Set mvarUploadObject = NewObject
End Property
Public Property Get UploadObject()
Set UploadObject = mvarUploadObject
End Property
Public Property Get FileObject()
Set FileObject = mvarFileObject
End Property
Public Property Let Name(ParameterName)
If mvarUploadObject is Nothing Then Exit Property
mvarName = ParameterName
Set mvarFileObject = mvarUploadObject.Files(ParameterName)
If Not mvarFileObject is Nothing Then
mvarFileName = mvarFileObject.FileName
mvarSize = mvarFileObject.Size
End If
End Property
Public Property Get Name()
Name = mvarName
End Property
Public Property Get FileExists()
If Not mvarFileObject is Nothing Then FileExists = (mvarFileName <> "") Else FileExists = False
End Property
Public Property Get Size()
Size = mvarSize
End Property
Public Property Get FileName()
FileName = mvarFileName
End Property
Public Function Save(NewFileName)
Save = False
If mvarFileObject is Nothing Then Exit Function
mvarFileObject.SaveAs NewFileName
Save = True
End Function
End Class
'End clsFileElement Class
'clsFormElement Class @0-55A85CA9
Class clsFormElement
Private mvarName
Private mvarUploadObject
Private mvarCount
Private mvarValue
Private Sub Class_Initialize()
Set mvarUploadObject = Nothing
End Sub
Private Sub Class_Terminate()
Set mvarUploadObject = Nothing
End Sub
Public Property Set UploadObject(NewObject)
Set mvarUploadObject = NewObject
End Property
Public Property Get UploadObject()
Set UploadObject = mvarUploadObject
End Property
Public Property Get Count()
Count = mvarCount
End Property
Public Property Get Item(Index)
Item = Empty
End Property
Public Property Let Name(ParameterName)
If mvarUploadObject is Nothing Then Exit Property
mvarValue = mvarUploadObject.Form(ParameterName).Value
mvarCount = IIf(IsEmpty(mvarValue), 0, 1)
mvarName = ParameterName
End Property
Public Property Get Name()
Name = mvarName
End Property
Public Default Property Get Value()
Value = mvarValue
End Property
End Class
'End clsFormElement Class
'clsUploadControl Class @0-12BA25AF
Class clsUploadControl
Private mvarUploadObject
Private mvarFilesCount
Private mvarFileElements
Private mvarFormElements
Private Sub Class_Initialize()
mvarFilesCount = 0
Set mvarUploadObject = Nothing
Set mvarFileElements = CreateObject("Scripting.Dictionary")
Set mvarFormElements = CreateObject("Scripting.Dictionary")
On Error Resume Next
Set mvarUploadObject = Server.CreateObject("Persits.Upload")
mvarUploadObject.IgnoreNoPost = True
mvarFilesCount = mvarUploadObject.Save
If Err.Number <> 0 Then
Response.Write "Die Persits Upload-Komponente ""Persits"" wurde nicht gefunden. Wählen Sie eine andere oder installieren Sie die Komponente."
Response.End
End If
On Error Goto 0
End Sub
Private Sub Class_Terminate()
mvarFileElements.RemoveAll
Set mvarFileElements = Nothing
mvarFormElements.RemoveAll
Set mvarFormElements = Nothing
Set mvarUploadObject = Nothing
End Sub
Public Property Get FilesCount()
FilesCount = mvarFilesCount
End Property
Public Property Get Form(ParameterName)
Dim FormElement
If Not mvarFormElements.Exists(LCase(ParameterName)) Then
Set FormElement = new clsFormElement
Set FormElement.UploadObject = mvarUploadObject
FormElement.Name = ParameterName
mvarFormElements.Add LCase(ParameterName), FormElement
Else
Set FormElement = mvarFormElements.Item(LCase(ParameterName))
End If
Set Form = FormElement
End Property
Public Property Get Files(ParameterName)
Dim FileElement
If Not mvarFileElements.Exists(LCase(ParameterName)) Then
Set FileElement = new clsFileElement
Set FileElement.UploadObject = mvarUploadObject
FileElement.Name = ParameterName
mvarFileElements.Add LCase(ParameterName), FileElement
Else
Set FileElement = mvarFileElements.Item(LCase(ParameterName))
End If
Set Files = FileElement
End Property
End Class
'End clsUploadControl Class
'CCCreateFileUpload Function @0-A734B792
Function CCCreateFileUpload(Name,Caption,TemporaryFolder,FileFolder,AllowedFileMasks,DisallowedFileMasks,FileSizeLimit,Required)
Dim FileUpload
Set FileUpload = New clsFileUpload
With FileUpload
.Name = Name
.DeleteControlName = Name & "_Delete"
.Caption = Caption
.TemporaryFolder = TemporaryFolder & "\"
.FileFolder = FileFolder & "\"
.AllowedFileMasks = AllowedFileMasks
.DisallowedFileMasks = DisallowedFileMasks
.FileSizeLimit = FileSizeLimit
.Required = Required
End With
Set CCCreateFileUpload = FileUpload
End Function
'End CCCreateFileUpload Function
'clsFileUpload Class @0-3C10B0C8
Class clsFileUpload
Public Name
Public CCSEvents
Public Visible
Public ExternalName
Public Errors
Public Caption
Public Required
Public TemplateBlock
Public AllowedFileMasks
Public DisallowedFileMasks
Public FileSizeLimit
Public IsUploaded
Public FileSize
Public fso
Public DeleteControlName
Public ExternalDeleteControlName
Private VarTemporaryFolder
Private VarFileFolder
Private VarValue
Private VarText
Private StateArray
Private IsCCSName
Private CCSEventResult
Private Sub Class_Initialize()
Set CCSEvents = CreateObject("Scripting.Dictionary")
Set fso = CreateObject("Scripting.FileSystemObject")
Set Errors = New clsErrors
ExternalName = Empty
Visible = True
IsUploaded = False
FileSize = 0
ReDim StateArray(1)
StateArray(0) = Empty
StateArray(1) = Empty
IsCCSName=True
End Sub
Private Sub Class_Terminate()
CCSEvents.RemoveAll
Set CCSEvents = Nothing
Set Errors = Nothing
Set fso = Nothing
End Sub
Public Function Upload(CurrentRow)
On Error Resume Next
Dim f, FieldName, NewFileName
If Not IsEmpty(CurrentRow) Then
ExternalName = Name & "_" & CStr(CurrentRow)
ExternalDeleteControlName = Name & "_Delete_" & CStr(CurrentRow)
End If
If CCGetRequestParam("ccsForm",ccsGet) <> "" Then
SetState CCGetRequestParam(IIf(Not IsEmpty(ExternalName), ExternalName, Name), ccsPost)
Value = StateArray(0)
End If
If UploadedFilesCount > 0 Then
If Not IsEmpty(objUpload.Files(IIf(Not IsEmpty(ExternalName), ExternalName, Name) & "_File")) Then _
Set f = objUpload.Files(IIf(Not IsEmpty(ExternalName), ExternalName, Name) & "_File")
If Not IsEmpty(f) Then
If f.FileExists Then
FileSize = f.Size
NewFileName = GetValidFileName(f.FileName) & f.FileName
CCSEventResult = CCRaiseEvent(CCSEvents, "OnRenameFile", Me)
If TypeName(CCSEventResult)="String" And CStr(CCSEventResult)<>"" Then NewFileName = CCSEventResult
f.Save VarTemporaryFolder & NewFileName
If Not Err.Number = 0 Then
If Not CStr(Caption) = "" Then FieldName = Caption Else FieldName = Name
Response.Write CCSRunTimeMessages.GetMessage("UploadingTempFolderError",Array("FieldName",FieldName, "Error", CStr(Err.Source) & ", " & CStr(Err.Description)))
Response.End
End If
StateArray(1) = NewFileName
If Not IsEmpty(StateArray(0)) And StateArray(1) <> StateArray(0) Then DeleteFile
Value = NewFileName
Else
If IsEmpty(StateArray(0)) Then
VarValue = ""
FileSize = 0
End If
End If
Else
If IsEmpty(StateArray(0)) Then
VarValue = ""
FileSize = 0
End If
StateArray(1) = Empty
End If
End If
If CCGetRequestParam(IIf(Not IsEmpty(ExternalDeleteControlName), ExternalDeleteControlName, DeleteControlName), ccsPost) <> "" Then DeleteFile
If Not Err.Number = 0 Then
If Not CStr(Caption) = "" Then FieldName = Caption Else FieldName = Name
Response.Write "Fehler beim Upload der im Feld " & FieldName & " angegebenen Datei. Fehler-Beschreibung: " & CStr(Err.Source) & ", " & CStr(Err.Description) & "."
Response.End
End If
End Function
Public Function GetFile(CurrentRow)
On Error Resume Next
Dim f, FieldName
If Not IsEmpty(CurrentRow) Then
ExternalName = Name & "_" & CStr(CurrentRow)
ExternalDeleteControlName = Name & "_Delete_" & CStr(CurrentRow)
End If
IsCCSName=True
If CCGetRequestParam("ccsForm",ccsGet) <> "" Then
SetState CCGetRequestParam(IIf(Not IsEmpty(ExternalName), ExternalName, Name), ccsPost)
Text = StateArray(0)
Value = Text
End If
If UploadedFilesCount > 0 Then
If Not IsEmpty(objUpload.Files(IIf(Not IsEmpty(ExternalName), ExternalName, Name) & "_File")) Then _
Set f = objUpload.Files(IIf(Not IsEmpty(ExternalName), ExternalName, Name) & "_File")
If Not IsEmpty(f) Then
If f.FileExists Then
FileSize = f.Size
Text = f.FileName
IsCCSName = False
Else
If IsEmpty(StateArray(0)) Then
Text = ""
FileSize = 0
End If
End If
Else
If IsEmpty(StateArray(0)) Then
Text = ""
FileSize = 0
End If
End If
End If
If Not Err.Number = 0 Then
If Not CStr(Caption) = "" Then FieldName = Caption Else FieldName = Name
Response.Write "Fehler beim Upload der im Feld " & FieldName & " angegebenen Datei. Fehler-Beschreibung: " & CStr(Err.Source) & ", " & CStr(Err.Description) & "."
Response.End
End If
End Function
Public Function MoveFromTempFolder
On Error Resume Next
Dim FieldName
CCSEventResult = CCRaiseEvent(CCSEvents, "BeforeProcessFile", Me)
If (fso.FileExists(VarTemporaryFolder & VarValue)) Then
fso.MoveFile VarTemporaryFolder & VarValue, VarFileFolder & VarValue
StateArray(0) = VarValue
StateArray(1) = VarValue
End If
CCSEventResult = CCRaiseEvent(CCSEvents, "AfterProcessFile", Me)
If Not Err.Number = 0 Then
If Not CStr(Caption) = "" Then FieldName = Caption Else FieldName = Name
Response.Write "Fehler beim Upload der im Feld " & FieldName & " angegebenen Datei. Fehler-Beschreibung: " & CStr(Err.Source) & ", " & CStr(Err.Description) & "."
Response.End
End If
End Function
Public Function DeleteFile()
On Error Resume Next
Dim FieldName, FileName
CCSEventResult = CCRaiseEvent(CCSEvents, "BeforeDeleteFile", Me)
FileName = VarValue
If IsEmpty(FileName) Then FileName = VarText
If (fso.FileExists(VarTemporaryFolder & FileName)) Then
fso.DeleteFile VarTemporaryFolder & FileName, True
VarValue = ""
End If
If (fso.FileExists(VarFileFolder & FileName)) Then
fso.DeleteFile VarFileFolder & FileName, True
VarValue = ""
End If
CCSEventResult = CCRaiseEvent(CCSEvents, "AfterDeleteFile", Me)
If Not Err.Number = 0 Then
If Not CStr(Caption) = "" Then FieldName = Caption Else FieldName = Name
Response.Write "Fehler beim Upload der im Feld " & FieldName & " angegebenen Datei. Fehler-Beschreibung: " & CStr(Err.Source) & ", " & CStr(Err.Description) & "."
Response.End
End If
End Function
Property Let TemporaryFolder(NewText)
Dim FieldName, regEx
VarTemporaryFolder = NewText
If UCase(Left(NewText, 5)) = "%TEMP" Then
VarTemporaryFolder = fso.GetSpecialFolder(2) & Mid(NewText, 6)
End If
If NewText = "" Then
VarTemporaryFolder = Server.MapPath(".\") & "\"
End If
Set regEx = New RegExp
regEx.Pattern = "^[a-z]:.*"
regEx.IgnoreCase = True
If Not regEx.Test(VarTemporaryFolder) Then VarTemporaryFolder = Server.MapPath(VarTemporaryFolder) & "\"
If Not fso.FolderExists(VarTemporaryFolder) Then
If Not CStr(Caption) = "" Then FieldName = Caption Else FieldName = Name
Response.Write "Der Upload der im Feld " & CStr(FieldName) & " angegebenen Datei ist nicht möglich - der temporäre Upload-Ordner existiert nicht."
Response.End
End If
End Property
Property Get TemporaryFolder()
TemporaryFolder = VarTemporaryFolder
End Property
Property Let FileFolder(NewText)
Dim FieldName, regEx
VarFileFolder = NewText
If UCase(Left(NewText, 5)) = "%TEMP" Then
VarFileFolder = fso.GetSpecialFolder(2) & Mid(NewText, 6)
End If
Set regEx = New RegExp
regEx.Pattern = "^[a-z]:.*"
regEx.IgnoreCase = True
If Not regEx.Test(VarFileFolder) Then VarFileFolder = Server.MapPath(VarFileFolder) & "\"
If Not fso.FolderExists(VarFileFolder) Then
If Not CStr(Caption) = "" Then FieldName = Caption Else FieldName = Name
Response.Write "Der Upload der im Feld " & CStr(FieldName) & " angegebenen Datei ist nicht möglich - der Upload-Ordner existiert nicht."
Response.End
End If
End Property
Property Get FileFolder()
FileFolder = CStr(VarFileFolder)
End Property
Property Let Value(NewValue)
On Error Resume Next
Dim f, FieldName
If Not IsEmpty(NewValue) Then
If Len(NewValue) > 0 Then
If (fso.FileExists(VarTemporaryFolder & NewValue)) Then
VarValue = NewValue
VarText = VarValue
StateArray(0) = NewValue
StateArray(1) = Empty
IsUploaded = True
Set f = fso.GetFile(VarTemporaryFolder & NewValue)
FileSize = f.Size
VarText = f.Path
ElseIf (fso.FileExists(VarFileFolder & NewValue)) Then
VarValue = NewValue
VarText = VarValue
StateArray(0) = NewValue
StateArray(1) = Empty
IsUploaded = True
Set f = fso.GetFile(VarFileFolder & NewValue)
FileSize = f.Size
End If
End If
End If
If Not IsEmpty(ExternalName) And NewValue = "" Then
VarValue = ""
VarText = ""
StateArray(0) = Empty
StateArray(1) = Empty
IsUploaded = False
FileSize = 0
End If
If Not Err.Number = 0 Then
If Not CStr(Caption) = "" Then FieldName = Caption Else FieldName = Name
Response.Write "Fehler beim Upload der im Feld " & FieldName & " angegebenen Datei. Fehler-Beschreibung: " & CStr(Err.Source) & ", " & CStr(Err.Description) & "."
Response.End
End If
End Property
Property Get Value()
Value = VarValue
End Property
Property Let Text(NewText)
Dim f
VarText = NewText
End Property
Property Get Text()
Text = CStr(VarText)
End Property
Public Function GetValidFileName(FileName)
On Error Resume Next
Dim dta, tm, index, prefix, FieldName
dta = Date()
tm = time()
index = 0
Do
prefix = Year(dta) & Month(dta) & Day(dta) & Hour(tm) & Minute(tm) & Second(tm) & CStr(index) & "."
index = index + 1
Loop While fso.FileExists(VarTemporaryFolder & prefix & FileName) Or fso.FileExists(VarFileFolder & prefix & FileName)
GetValidFileName = prefix
If Not Err.Number = 0 Then
If Not CStr(Caption) = "" Then FieldName = Caption Else FieldName = Name
Response.Write "Fehler beim Upload der im Feld " & FieldName & " angegebenen Datei. Fehler-Beschreibung: " & CStr(Err.Source) & ", " & CStr(Err.Description) & "."
Response.End
End If
End Function
Public Function GetOriginFileName(FileName)
Dim nPos
nPos = InStr(FileName,".")
If nPos > 0 Then
GetOriginFileName = Mid(FileName,nPos+1)
Else
GetOriginFileName = FileName
End If
End Function
Function Validate()
Dim FieldName,oVarText
If Required And CStr(VarText) = "" Then
If Not CStr(Caption) = "" Then FieldName = Caption Else FieldName = Name
Errors.addError("Die im Feld " & FieldName & " bennante Datei fehlt.")
End If
oVarText = IIF(IsUploaded And IsCCSName,GetOriginFileName(VarText),VarText)
If Not CStr(Text) = "" And DisallowedFileMasks <> "" And CCRegExpTest(oVarText, "^" & Replace(Replace(Replace(Replace(DisallowedFileMasks, ".", "\."), "?", "."), "*", ".*"), ";", "$|^") & "$", True, True) And Errors.Count = 0 Then
If Not CStr(Caption) = "" Then FieldName = Caption Else FieldName = Name
Errors.addError("Der im Feld " & FieldName & " eingegebene Dateityp ist nicht erlaubt.")
End If
If Not CStr(Text) = "" And AllowedFileMasks <> "" And AllowedFileMasks <> "*" And Not CCRegExpTest(oVarText, "^" & Replace(Replace(Replace(Replace(AllowedFileMasks,".", "\."), "?", "."), "*", ".*"), ";", "$|^") & "$", True, True) And Errors.Count = 0 Then
If Not CStr(Caption) = "" Then FieldName = Caption Else FieldName = Name
Errors.addError("Der im Feld " & FieldName & " eingegebene Dateityp ist nicht erlaubt.")
End If
If Not IsUploaded And FileSize > FileSizeLimit And Errors.Count = 0 Then
If Not CStr(Caption) = "" Then FieldName = Caption Else FieldName = Name
Errors.addError("Die im Feld " & FieldName & " eingegebene Dateigröße ist zu groß.")
End If
If Errors.Count > 0 And fso.FileExists(VarTemporaryFolder & VarText) Then DeleteFile
Validate = CCRaiseEvent(CCSEvents, "OnValidate", Me)
End Function
Sub Show(Template)
Dim TemplateBlock, UploadBlock, InfoBlock, DeleteControlBlock
CCSEventResult = CCRaiseEvent(CCSEvents, "BeforeShow", Me)
If Visible Then
Set TemplateBlock = Template.Block("FileUpload " & Name)
Set UploadBlock = TemplateBlock.Block("Upload")
Set InfoBlock = TemplateBlock.Block("Info")
Set DeleteControlBlock = TemplateBlock.Block("DeleteControl")
If Not (TemplateBlock Is Nothing) Then
If IsEmpty(ExternalName) Then
TemplateBlock.Variable("ControlName") = Name
Else
TemplateBlock.Variable("ControlName") = ExternalName
End If
TemplateBlock.Variable("State") = GetState()
If (Not IsUploaded Or Required) And Not (UploadBlock Is Nothing) Then
If IsEmpty(ExternalName) Then
UploadBlock.Variable("FileControl") = Name & "_File"
Else
UploadBlock.Variable("FileControl") = ExternalName & "_File"
End If
UploadBlock.Parse ccsParseOverwrite
InfoBlock.Visible = False
DeleteControlBlock.Visible = False
End If
If IsUploaded And Not (InfoBlock Is Nothing) Then
InfoBlock.Variable("FileName") = GetOriginFileName(Server.HTMLEncode(VarValue))
InfoBlock.Variable("FileSize") = FileSize
InfoBlock.Parse ccsParseOverwrite
UploadBlock.Visible = Required
End If
If IsUploaded And Not Required And Not (DeleteControlBlock Is Nothing) Then
If IsEmpty(ExternalDeleteControlName) Then
DeleteControlBlock.Variable("DeleteControl") = DeleteControlName
Else
DeleteControlBlock.Variable("DeleteControl") = ExternalDeleteControlName
End If
DeleteControlBlock.Parse ccsParseOverwrite
UploadBlock.Visible = Required
End If
TemplateBlock.Parse ccsParseOverwrite
End if
End If
End Sub
Function OnClick()
OnClick = CCRaiseEvent(CCSEvents, "OnClick", Me)
End Function
Private Function GenerateStateKey()
Dim dta, tm, random_number
dta = Date()
tm = time()
Randomize
random_number = Abs(Int((2147483647 + 2147483648 + 1) * Rnd - 2147483648))
GenerateStateKey = CStr(random_number) & Day(dta) & Hour(tm) & Minute(tm) & Second(tm)
End Function
Private Function GetState()
Dim ControlStateKey
If StateArray(0) = Empty Then StateArray(0) = Value
ControlStateKey = GenerateStateKey()
Session(ControlStateKey) = StateArray
GetState = ControlStateKey
End Function
Private Function SetState(value)
If IsArray(Session(value)) Then
StateArray(0) = Session(value)(0)
StateArray(1) = Session(value)(1)
Else
StateArray(0) = Empty
StateArray(1) = Empty
End If
End Function
End Class
'End clsFileUpload Class
'CCCreateButton Function @0-E8E95E8F
Function CCCreateButton(Name)
Dim Button
Set Button = New clsButton
Button.Name = Name
Set CCCreateButton = Button
End Function
'End CCCreateButton Function
'clsButton Class @0-FE2F9E8E
Class clsButton
Public Name
Public CCSEvents
Public Visible
Public ExternalName
Private CCSEventResult
Private Sub Class_Initialize()
Set CCSEvents = CreateObject("Scripting.Dictionary")
ExternalName = Empty
Visible = True
End Sub
Private Sub Class_Terminate()
Set CCSEvents = Nothing
End Sub
Sub Show(Template)
CCSEventResult = CCRaiseEvent(CCSEvents, "BeforeShow", Me)
If Visible Then
If Template.BlockExists("Button " & Name, "block") Then
Template.Block("Button " & Name).Variable("Button_Name") = Name
Template.Block("Button " & Name).Parse ccsParseOverwrite
End If
End If
End Sub
Function OnClick()
OnClick = CCRaiseEvent(CCSEvents, "OnClick", Me)
End Function
End Class
'End clsButton Class
'CCCreateDatePicker Function @0-C5EDAC24
Function CCCreateDatePicker(Name, FormName, ControlName)
Dim DatePicker
Set DatePicker = New clsDatePicker
With DatePicker
.Name = Name
.FormName = FormName
.ControlName = ControlName
End With
Set CCCreateDatePicker = DatePicker
End Function
'End CCCreateDatePicker Function
'clsDatePicker Class @0-B0B324C1
Class clsDatePicker
Public Name
Public ExternalName
Public FormName
Public ControlName
Public ExternalControlName
Public Visible
Private Sub Class_Initialize()
ExternalName = Empty
ExternalControlName = Empty
Visible = True
End Sub
Sub Show(Template)
Dim TemplateBlock
If Visible Then
Set TemplateBlock = Template.Block("DatePicker " & Name)
If Template.BlockExists("DatePicker " & Name, "block") Then
TemplateBlock.Variable("Name") = CStr(FormName) & "_" & CStr(Name)
TemplateBlock.Variable("FormName") = CStr(FormName)
If IsEmpty(ExternalControlName) Then
TemplateBlock.Variable("DateControl") = CStr(ControlName)
Else
TemplateBlock.Variable("DateControl") = CStr(ExternalControlName)
End If
TemplateBlock.Parse ccsParseOverwrite
End If
End If
End Sub
End Class
'End clsDatePicker Class
'CCCreateList Function @0-54E52904
Function CCCreateList(ControlType, Name, Caption, DataType, InitValue, DataSource)
Dim Control
Set Control = New clsListControl
With Control
.Name = Name
.ControlType = ControlType
.Caption = Caption
.DataType = DataType
.ControlTypeName = ccsControlTypes(ControlType)
If IsArray(InitValue) Then
.MultipleValues = InitValue
Else
.Text = InitValue
End If
If IsObject(DataSource) Then
Set .DataSource = DataSource
End If
End With
Set CCCreateList = Control
End Function
'End CCCreateList Function
'clsListControl Class @0-3FC4C78F
Class clsListControl
Private Control
Private DataTypeValue
Public CCSEvents
Public DataSource
Public Recordset
Public Errors
Public Name
Public ControlType
Public Caption
Public Required
Public TemplateBlock
Public Visible
Public HTML
Public MultipleValues
Public IsMultiple
Public ExternalName
Public ControlTypeName
Public TextColumn
Public BoundColumn
Private CCSEventResult
Private mPopulatingType
Public IsPopulated
Public ItemsList()
Public KeysList()
Public ItemsCount
Private Sub Class_Initialize()
Required = False
BoundColumn = 0
TextColumn = 1
Visible = True
PopulatingType = ccsStringConcats
HTML = False
ExternalName = Empty
IsPopulated = False
ItemsCount = 0
Set Control = New clsControl
Set CCSEvents = CreateObject("Scripting.Dictionary")
Set Errors = New clsErrors
End Sub
Private Sub Class_Terminate()
Set Control = Nothing
Set Errors = Nothing
Set DataSource = Nothing
Set Recordset = Nothing
Set CCSEvents = Nothing
End Sub
Public Function AddValue(NewValue)
Dim NumberOfValues
NumberOfValues = Ubound(MultipleValues)
ReDim Preserve MultipleValues(NumberOfValues + 1)
MultipleValues(NumberOfValues + 1) = NewValue
End Function
Public Function HasMultipleValues
If IsArray(MultipleValues) Then
HasMultipleValues = (Ubound(MultipleValues) > 0)
Else
HasMultipleValues = False
End If
End Function
Property Let Value(NewValue)
If IsMultiple Then
If HasMultipleValues Then
MultipleValues(1) = NewValue
Else
AddValue NewValue
End If
End If
Control.Value = NewValue
End Property
Property Get Value()
If IsMultiple And HasMultipleValues Then
Value = MultipleValues(1)
Else
Value = Control.Value
End If
End Property
Public Property Let PopulatingType(vType)
mPopulatingType = vType
End Property
Public Property Get PopulatingType()
PopulatingType = mPopulatingType
End Property
Property Let DataType(NewDataType)
DataTypeValue = NewDataType
Control.DataType = DataTypeValue
End Property
Property Get DataType()
DataType = DataTypeValue
End Property
Property Get SQLValue()
SQLValue = Control.SQLValue
End Property
Function Validate()
Dim FieldName,Passed
If Required Then
If IsMultiple Then
Passed = (Ubound(MultipleValues) = 0)
Else
Passed = (CStr(Control.Value) = "")
End If
If Passed Then
If Not CStr(Caption) = "" Then FieldName = Caption Else FieldName = Name
Errors.addError(CCSRunTimeMessages.GetMessage("RequiredField", Array("FieldName", FieldName)))
End If
End If
Validate = CCRaiseEvent(CCSEvents, "OnValidate", Me)
End Function
Public Sub RePopulate
Dim cmdErrors, MaxBound, i
Dim RSFields
If NOT IsObject(DataSource) Then Exit Sub
Set cmdErrors = new clsErrors
Set Recordset = DataSource.Exec(cmdErrors)
Set RSFields = new clsFields
RSFields.AddFields Array(CCCreateField("BoundColumn", BoundColumn, DataTypeValue, Empty, Recordset), _
CCCreateField("TextColumn", TextColumn, ccsText, Empty, Recordset))
Set Recordset.FieldsCollection = RSFields
If cmdErrors.Count > 0 Then
Dim ErrorString
If ControlType = ccsRadioButton Then
ErrorString = "RadioButton " & Name
ElseIf ControlType = ccsListBox Then
ErrorString = "ListBox " & Name
Else
ErrorString = "CheckBoxList" & Name
End If
PrintDBError CCToHTML(ErrorString), "", cmdErrors.ToString()
Else
MaxBound = 25: i = 1
ReDim ItemsList(MaxBound)
ReDim KeysList (MaxBound)
While NOT Recordset.EOF
If i >= MaxBound Then
MaxBound = MaxBound + 25
ReDim Preserve ItemsList(MaxBound)
ReDim Preserve KeysList (MaxBound)
End If
ItemsList(i) = Recordset.Fields("TextColumn")
KeysList(i) = Recordset.Fields("BoundColumn")
i = i + 1
Recordset.MoveNext
Wend
End If
Recordset.Close
IsPopulated = True
ItemsCount = i - 1
Set cmdErrors = Nothing
End Sub
Sub Show(Template)
Dim Result, Selected, Recordset, ResultBuffer, i, j
Dim cmdErrors
Dim NeedShow
If NOT IsObject(DataSource) Then Exit Sub
If Not IsPopulated Then RePopulate()
Set TemplateBlock = Template.Block(ControlTypeName & " " & Name)
NeedShow = NOT (TemplateBlock Is Nothing)
If ControlType = ccsListBox Then
If NOT NeedShow Then _
Set TemplateBlock = Template
End If
If IsEmpty(ExternalName) Then
TemplateBlock.Variable(Name & "_Name") = Name
Else
TemplateBlock.Variable(Name & "_Name") = ExternalName
End If
CCSEventResult = CCRaiseEvent(CCSEvents, "BeforeShow", Me)
If NOT Visible Then
If NeedShow Then TemplateBlock.Clear
Exit Sub
End If
If ControlType = ccsRadioButton or ControlType = ccsCheckBoxList Then
TemplateBlock.Clear
For j = 1 To ItemsCount
Selected = ""
If IsMultiple Then
For i = 1 To Ubound(MultipleValues)
If UCase(CStr(KeysList(j))) = UCase(CStr(MultipleValues(i))) Then
Selected = " CHECKED"
End If
Next
Else
If UCase(CStr(KeysList(j))) = UCase(CStr(Value)) Then
Selected = " CHECKED"
End If
End If
TemplateBlock.Variable("Value") = CCSConverter.TypeToString(DataType, KeysList(j), Empty)
TemplateBlock.Variable("Check") = Selected
If HTML Then
TemplateBlock.Variable("Description") = CStr(ItemsList(j))
Else
TemplateBlock.Variable("Description") = Server.HTMLEncode(CStr(ItemsList(j)))
End If
TemplateBlock.Parse True
Next
ElseIf ControlType = ccsListBox Then
Set ResultBuffer = new clsStringBuffer
Result = ""
If mPopulatingType = ccsStringConcats Then
For j = 1 To ItemsCount
Selected = ""
If IsMultiple Then
For i = 1 To Ubound(MultipleValues)
If UCase(CStr(KeysList(j))) = UCase(CStr(MultipleValues(i))) Then
Selected = " SELECTED"
Exit For
End If
Next
Else
If UCase(CStr(KeysList(j))) = UCase(CStr(Value)) Then
Selected = " SELECTED"
End If
End If
Result = Result & "" & vbNewLine
Next
Else
For j = 1 To ItemsCount
Selected = ""
If IsMultiple Then
For i = 1 To Ubound(MultipleValues)
If UCase(CStr(KeysList(j))) = UCase(CStr(MultipleValues(i))) Then
Selected = " SELECTED"
Exit For
End If
Next
Else
If UCase(CStr(KeysList(j))) = UCase(CStr(Value)) Then
Selected = " SELECTED"
End If
End If
ResultBuffer.Append "" & vbNewLine
Next
Result = ResultBuffer.ToString
End If
TemplateBlock.Variable(Name & "_Options") = Result
If NeedShow Then TemplateBlock.Show
End If
Set TemplateBlock = Nothing
End Sub
Property Get Text()
Text = Control.Text
End Property
Property Let Text(NewText)
Control.Text = NewText
End Property
Property Get SQLText()
SQLText = Control.SQLText
End Property
Property Let SQLText(NewSQLText)
Control.SQLText = NewSQLText
End Property
End Class
'End clsListControl Class
'clsErrors Class @0-DC79566E
Class clsErrors
Private ErrorsCount
Private Errors
Public ErrorDelimiter
Private Sub Class_Initialize()
Clear
ErrorDelimiter = " "
End Sub
Sub AddError(Description)
If NOT(CStr(Description) = "") Then
ReDim Preserve Errors(ErrorsCount)
Errors(ErrorsCount) = Description
ErrorsCount = ErrorsCount + 1
End If
End Sub
Sub AddErrors(objErrors)
Dim I
For I = 0 To objErrors.Count - 1
AddError(objErrors.ErrorByNumber(I))
Next
End Sub
Sub Clear()
ErrorsCount = 0
ReDim Errors(1)
End Sub
Property Get Count()
Count = ErrorsCount
End Property
Property Get ErrorByNumber(ErrorNumber)
If ErrorNumber > ErrorsCount OR ErrorNumber < 0 Then
Err.Raise 4001, "Error class, ErrorByNumber function. Parameter out of range."
End If
ErrorByNumber = Errors(ErrorNumber)
End Property
Property Get ToString()
If ErrorsCount > 0 Then
ToString = Join(Errors, ErrorDelimiter) & ErrorDelimiter
Else
ToString = ""
End If
End Property
End Class
'End clsErrors Class
'CCCreateDataSource Function @0-07E5CF26
Function CCCreateDataSource(DataSourceType, Connection, CommandSource)
Dim Cmd
Set Cmd = New clsCommand
If DataSourceType <> dsListOfValues Then
Set Cmd.Connection = Connection
Set Cmd.WhereParameters.Connection = Connection
End If
Cmd.CommandType = DataSourceType
Cmd.CommandOperation = cmdOpen
Cmd.ActivePage = -1
Select Case DataSourceType
Case dsTable
Cmd.SQL = CommandSource(0)
Cmd.Where = CommandSource(1)
Cmd.OrderBy = CommandSource(2)
Case dsSQL
Cmd.SQL = CommandSource
Case dsProcedure
Set Cmd.SQL = CommandSource
Case dsListOfValues
Cmd.LOV = CommandSource
End Select
Set CCCreateDataSource = Cmd
End Function
'End CCCreateDataSource Function
'clsEmptyDataSource Class @0-79DF4DE2
Class clsEmptyDataSource
Public Errors
Public CCSEvents
Private Sub Class_Initialize()
Set CCSEvents = CreateObject("Scripting.Dictionary")
Set Errors = New clsErrors
End Sub
Private Sub Class_Terminate()
Set CCSEvents = Nothing
Set Errors = Nothing
End Sub
Function Open(Cmd)
Set Open = Me
End Function
Property Get EOF()
EOF = True
End Property
Property Get State()
State = adStateClosed
End Property
Property Get Fields(Name)
Fields = Empty
End Property
End Class
'End clsEmptyDataSource Class
'clsDataSource Class @0-91D5AB91
Class clsDataSource
Public DataSourceType
Public DataSource
Public Errors, Connection, Parameters, CCSEvents
Public Recordset
Public PageSize
Public Command
Private mRecordCount
Public Order
Private objFields
Private AbsolutePage
Private builtSQL
Private Opened
Private MemoFields
Private Sub Class_Initialize()
Set CCSEvents = CreateObject("Scripting.Dictionary")
Set MemoFields = CreateObject("Scripting.Dictionary")
Set Errors = New clsErrors
Set Parameters = New clsSQLParameters
Set Parameters.DataSource = Me
AbsolutePage = 0
RecordCount = -1
Opened = False
End Sub
Sub Close()
If Recordset.State = adStateOpen Then
Recordset.Close
End If
Opened = False
Set Recordset = Nothing
End Sub
Function GetData(Pages)
If Pages = 0 Then
Set GetData = Recordset
End If
End Function
Property Get Fields(Name)
If IsNumeric(Name) Then
Fields = CCGetValue(Recordset, CInt(Name))
ElseIf IsObject(objFields) Then
If Not objFields is Nothing Then
If objFields.Exists(Name) Then
If MemoFields.Exists(objFields(Name).DBFieldName) Then
Fields = MemoFields(objFields(Name).DBFieldName)
Else
Fields = objFields(Name).Value
If objFields(Name).DataType = ccsMemo Then
MemoFields.Add objFields(Name).DBFieldName, Fields
End If
End If
Else
Fields = CCGetValue(Recordset, Name)
End If
Else
Fields = CCGetValue(Recordset, Name)
End If
Else
Fields = CCGetValue(Recordset, Name)
End If
End Property
Property Set FieldsCollection(NewFieldsCollection)
Set objFields = NewFieldsCollection
If Not objFields Is Nothing Then
objFields.InitEnum
While Not objFields.EndOfEnum
Set objFields.NextItem.DataSource = Me
Wend
End If
End Property
Property Get EOF()
EOF = Recordset.EOF
End Property
Property Get State()
If IsObject(Recordset) Then
State = Recordset.State
Else
State = False
End If
End Property
Sub MoveNext()
Recordset.MoveNext
MemoFields.RemoveAll
End Sub
Sub MoveFirst()
Recordset.MoveFirst
MemoFields.RemoveAll
End Sub
Function GetOrder(DefaultSorting, Sorter, Direction, MapArray)
Dim OrderValue, I, ActiveSorter
If NOT IsEmpty(Sorter) Then
' Select sorted column
I = 0
Do While I <= UBound(MapArray)
If MapArray(I)(0) = Sorter Then
ActiveSorter = I
Exit Do
End If
I = I + 1
Loop
If NOT IsEmpty(ActiveSorter) Then
If NOT IsEmpty(Direction) AND (Direction = "ASC" OR Direction = "DESC") Then
If Direction = "ASC" Then
OrderValue = MapArray(ActiveSorter)(1)
ElseIf Direction = "DESC" Then
OrderValue = MapArray(ActiveSorter)(2)
End If
If OrderValue = "" Then
OrderValue = MapArray(ActiveSorter)(1) & " DESC"
End If
Else
OrderValue = MapArray(ActiveSorter)(1)
End If
End If
End If
If Len(OrderValue) > 0 Then
Order = OrderValue
Else
Order = DefaultSorting
End If
GetOrder = Order
End Function
Public Property Let RecordCount(vData)
mRecordCount = vData
End Property
Public Property Get RecordCount()
If mRecordCount < 0 Then
mRecordCount = Command.ExecuteCount
End If
RecordCount = mRecordCount
End Property
Function MoveToPage(Page)
Dim PageCounter
Dim RecordCounter
If Recordset.State = adStateOpen Then
PageCounter = 1
RecordCounter = 1
While NOT Recordset.EOF AND PageCounter < Page
If RecordCounter MOD Command.PageSize = 0 Then
PageCounter = PageCounter + 1
End If
RecordCounter = RecordCounter + 1
Recordset.MoveNext
Wend
End If
Command.ActivePage = PageCounter
End Function
Function PageCount()
Dim Result
If Command.PageSize > 0 Then
Result = RecordCount \ Command.PageSize
If (RecordCount MOD Command.PageSize) > 0 Then
Result = Result + 1
End If
Else
Result = 1
End If
PageCount = Result
End Function
Private Sub Class_Terminate()
Set Command = Nothing
Set Errors = Nothing
Set Parameters = Nothing
Set CCSEvents = Nothing
End Sub
End Class
'End clsDataSource Class
'clsCommand Class @0-A8F5925B
Class clsCommand
Private mCommandType
Private mCommandOperation
Private mPrepared
Private mSQL
Private mCountSQL
Private mWhere
Private mOrderBy
Private mLOV
Private mSP
Private mPageSize
Private mActivePage
Public Errors, Connection, CCSEvents
Public WhereParameters, Parameters
Public CommandParameters
Public Options
Private IsNeedMoveToPage
Private Sub Class_Initialize()
Set CCSEvents = CreateObject("Scripting.Dictionary")
Set WhereParameters = New clsSQLParameters
Set WhereParameters.ParameterSources = CreateObject("Scripting.Dictionary")
Set Parameters = New clsSQLParameters
Set Parameters.ParameterSources = CreateObject("Scripting.Dictionary")
Set Options = CreateObject("Scripting.Dictionary")
ActivePage = 0
Prepared = False
IsNeedMoveToPage=True
End Sub
Public Function Exec(Err)
Set Errors = Err
Select Case CommandOperation
Case cmdOpen
Set Exec = DoOpen
Case cmdExec
DoExec
End Select
End Function
Private Function OpenRecordset(sSQL,isCountSQL)
Dim Command
Dim Recordset
If Not isCountSQL And Options.Count>0 Then
Dim Page : Page=IIF(mActivePage>0,mActivePage,1)
Dim Size : Size=IIF(mPageSize>0,mPageSize,1)
If Options.Exists("TOP") Then
sSQL=Replace(sSQL,"{SqlParam_endRecord}", Page * Size , 1, 1)
End If
If Options.Exists("LIMIT MYSQL") Then
sSQL = sSQL & " LIMIT " & (Page - 1) * Size & " , " & Size
IsNeedMoveToPage=False
End If
If Options.Exists("LIMIT POSTGRES") Then
sSQL = sSQL & " LIMIT " & Size & " OFFSET " & (Page - 1) * Size
IsNeedMoveToPage=False
End If
End If
Set Command = CreateObject("ADODB.Command")
Command.CommandType = adCmdText
Command.CommandText = sSQL
Set Command.ActiveConnection = Connection.Connection
Set Recordset = Connection.Execute(Command)
If Connection.Errors.Count > 0 Then
Errors.AddError Connection.Errors.ToString & Errors.ErrorDelimiter
End If
Set OpenRecordset = Recordset
Set Command = Nothing
End Function
Private Function ParseParams(sSQL, Params)
Dim I
Dim NewSQL
Dim ParamKeys
Dim ParamItems
NewSQL = sSQL
If CommandType = dsSQL Then
If Not Params is Nothing Then
ParamItems = Params.ParametersList.Items
ParamKeys = Params.ParametersList.Keys
For I = 0 To UBound(ParamItems)
NewSQL = Replace(NewSQL, "{" & ParamKeys(I) & "}", ParamItems(I).SQLText)
Next
End If
End If
ParseParams = NewSQL
End Function
Private Function DoOpen()
Dim Command
Dim builtSQL
Dim DataSource
Dim CountRecordset
Dim ResultRecordset
Dim CCSEventResult
Dim ParameterValue
Dim Parameter
Set DataSource = new clsDataSource
If IsObject(Connection) Then _
Set DataSource.Connection = Connection
Set DataSource.Command = Me
Select Case CommandType
Case dsTable, dsSQL
CCSEventResult = CCRaiseEvent(CCSEvents, "BeforeBuildSelect", Me)
builtSQL = ParseParams(SQL & IIf(Len(Where) > 0, " WHERE " & Where, "") & IIf(Len(OrderBy) > 0, " ORDER BY " & OrderBy, ""), WhereParameters)
CCSEventResult = CCRaiseEvent(CCSEvents, "BeforeExecuteSelect", Me)
Set DataSource.Recordset = OpenRecordset(builtSQL,False)
If ActivePage > 0 And IsNeedMoveToPage Then
DataSource.MoveToPage ActivePage
End If
CCSEventResult = CCRaiseEvent(CCSEvents, "AfterExecuteSelect", Me)
If Errors.Count > 0 Then
DataSource.Errors.AddErrors Errors
End If
Set DoOpen = DataSource
Case dsProcedure
CCSEventResult = CCRaiseEvent(CCSEvents, "BeforeBuildSelect", Me)
Set Command = CreateSP()
CCSEventResult = CCRaiseEvent(CCSEvents, "BeforeExecuteSelect", Me)
Set DataSource.Recordset = Connection.Execute(Command)
If ActivePage > 0 Then
DataSource.MoveToPage ActivePage
End If
Do Until DataSource.Recordset Is Nothing
If DataSource.Recordset.Fields.Count >0 Then Exit Do
Set DataSource.Recordset = DataSource.Recordset.NextRecordset
Loop
If Connection.Errors.Count > 0 Then
DataSource.Errors.AddError Connection.Errors.ToString & Errors.ErrorDelimiter
End If
Set Command = Nothing
Set DoOpen = DataSource
Case dsListOfValues
Dim I
CCSEventResult = CCRaiseEvent(CCSEvents, "BeforeBuildSelect", Me)
Set DataSource.Recordset = CreateObject("ADODB.Recordset")
DataSource.Recordset.Fields.Append "bound", adBSTR, 256, adFldCacheDeferred + adFldUpdatable
DataSource.Recordset.Fields.Append "text", adBSTR, 256, adFldCacheDeferred + adFldUpdatable
CCSEventResult = CCRaiseEvent(CCSEvents, "BeforeExecuteSelect", Me)
DataSource.Recordset.Open
For I = 0 To UBound(mLOV(0))
DataSource.Recordset.AddNew
DataSource.Recordset.Fields("bound").Value = mLOV(0)(I)
DataSource.Recordset.Fields("text").Value = mLOV(1)(I)
Next
DataSource.Recordset.Update
DataSource.Recordset.MoveFirst
CCSEventResult = CCRaiseEvent(CCSEvents, "AfterExecuteSelect", Me)
Set DoOpen = DataSource
End Select
End Function
Public Function ExecuteCount()
Dim Result: Result = 0
Dim builtSQL: builtSQL = ""
Dim CountRecordset
If Len(CountSQL) > 0 Then
builtSQL = ParseParams(CountSQL & IIf(Len(Where) > 0, " WHERE " & Where, ""), WhereParameters)
Set CountRecordset = OpenRecordset(builtSQL,True)
If CountRecordset.State = adStateOpen Then
Result = CLng(CountRecordset.Fields(0).Value)
End If
Set CountRecordset = Nothing
End If
ExecuteCount = Result
End Function
Private Function CreateSP()
Dim Command, I, ParameterValue, Parameter, Sources
Set Command = Server.CreateObject("ADODB.Command")
Set Command.ActiveConnection = Connection.Connection
Command.CommandType = adCmdStoredProc
Command.CommandText = mSP
If IsArray(CommandParameters) Then
Set Sources = Parameters.ParameterSources
For I = 0 To UBound(CommandParameters)
ParameterValue = Sources(CommandParameters(I)(1))
If IsEmpty(ParameterValue) Then
ParameterValue = CommandParameters(I)(7)
End If
If IsEmpty(ParameterValue) Then
ParameterValue = Null
End If
Set Parameter = Command.CreateParameter(CommandParameters(I)(0), CommandParameters(I)(2), CommandParameters(I)(3), CommandParameters(I)(4), ParameterValue)
If Parameter.Type = adNumeric Then
Parameter.NumericScale = CommandParameters(I)(5)
Parameter.Precision = CommandParameters(I)(6)
End If
Command.Parameters.Append Parameter
Next
Set Sources = Nothing
End If
Set CreateSP = Command
End Function
Private Sub DoExec
Dim Command, I
Dim builtSQL
Dim ParameterValue, ParameterLength
If CommandType = dsProcedure Then
Set Command = CreateSP()
Else
Set Command = CreateObject("ADODB.Command")
Command.CommandType = adCmdText
builtSQL = SQL
If CommandType = dsSQL Then
builtSQL = ParseParams(builtSQL, WhereParameters)
builtSQL = ParseParams(builtSQL, Parameters)
Else
If IsArray(CommandParameters) Then
For I = 0 To UBound(CommandParameters)
If IsEmpty(CommandParameters(I)(4)) Then
ParameterValue = Null
ParameterLength = 1
Else
ParameterValue = CommandParameters(I)(4)
ParameterLength=CommandParameters(I)(3)
End If
Command.Parameters.Append Command.CreateParameter(CommandParameters(I)(0), CommandParameters(I)(1), CommandParameters(I)(2), ParameterLength, ParameterValue)
Next
End If
End If
Command.CommandText = builtSQL
Command.Prepared = Prepared
Set Command.ActiveConnection = Connection.Connection
End If
Connection.Execute(Command)
If Connection.Errors.Count > 0 Then
Errors.AddError Connection.Errors.ToString & Errors.ErrorDelimiter
End If
Set Command = Nothing
End Sub
Public Property Let ActivePage(vData)
mActivePage = vData
End Property
Public Property Get ActivePage()
ActivePage = mActivePage
End Property
Public Property Let PageSize(vData)
mPageSize = vData
End Property
Public Property Get PageSize()
PageSize = mPageSize
End Property
Public Property Let CommandOperation(vData)
mCommandOperation = vData
End Property
Public Property Get CommandOperation()
CommandOperation = mCommandOperation
End Property
Public Property Let LOV(vData)
mLOV = vData
End Property
Public Property Get LOV()
LOV = mLOV
End Property
Public Property Let SP(vData)
mSP = vData
End Property
Public Property Get SP()
SP = mSP
End Property
Public Property Let CountSQL(vData)
mCountSQL = vData
End Property
Public Property Get CountSQL()
CountSQL = mCountSQL
End Property
Public Property Let SQL(vData)
mSQL = vData
End Property
Public Property Get SQL()
SQL = mSQL
End Property
Public Property Let Prepared(vData)
mPrepared = vData
End Property
Public Property Get Prepared()
Prepared = mPrepared
End Property
Public Property Let CommandType(vData)
mCommandType = vData
End Property
Public Property Get CommandType()
CommandType = mCommandType
End Property
Public Property Let OrderBy(vData)
mOrderBy = vData
End Property
Public Property Get OrderBy()
OrderBy = mOrderBy
End Property
Public Property Let Order(vData)
mOrderBy = vData
End Property
Public Property Get Order()
Order = mOrderBy
End Property
Public Property Let Where(vData)
mWhere = vData
End Property
Public Property Get Where()
Where = mWhere
End Property
Public Sub Class_Terminate()
Set Options = Nothing
Set CCSEvents = Nothing
End Sub
End Class
'End clsCommand Class
'clsConverter Class @0-5DD64A8C
Class clsConverter
Private mDateFormat
Private mBooleanFormat
Private mIntegerFormat
Private mFloatFormat
Private mParseError
Private Sub Class_Initialize()
mParseError = False
End Sub
Property Let DateFormat(newDateFormat)
mDateFormat = newDateFormat
End Property
Property Get DateFormat()
DateFormat = mDateFormat
End Property
Property Let BooleanFormat(newFormat)
mBooleanFormat = newFormat
End Property
Property Get BooleanFormat()
BooleanFormat = mBooleanFormat
End Property
Property Let IntegerFormat(newFormat)
mIntegerFormat = newFormat
End Property
Property Get IntegerFormat()
IntegerFormat = mIntegerFormat
End Property
Property Let FloatFormat(newFormat)
mFloatFormat = newFormat
End Property
Property Get FloatFormat()
FloatFormat = mFloatFormat
End Property
Property Get ParseError()
ParseError = mParseError
End Property
Public Function VBSConvert(DataType, Value)
Dim Result
mParseError = False
Result = Empty
If IsEmpty(Value) Then
VBSConvert = Result
Exit Function
End If
On Error Resume Next
Select Case DataType
Case ccsDate
Result = CDate(Value)
Case ccsBoolean
Result = CBool(Value)
Case ccsInteger
Result = CLng(Value)
Case ccsFloat
Result = CDbl(Value)
Case ccsText, ccsMemo
Result = CStr(Value)
End Select
If Err.Number <> 0 Then _
mParseError = True
On Error Goto 0
VBSConvert = Result
End Function
Public Function StringToType(DataType, Value, Format)
Dim CurrentFormat
Dim Result
mParseError = False
Result = Empty
If IsEmpty(Value) Then
StringToType = Result
Exit Function
End If
If IsEmpty(Format) Then
Select Case DataType
Case ccsDate
CurrentFormat = mDateFormat
Case ccsBoolean
CurrentFormat = mBooleanFormat
Case ccsInteger
CurrentFormat = mIntegerFormat
Case ccsFloat
CurrentFormat = mFloatFormat
End Select
Else
CurrentFormat = Format
End If
On Error Resume Next
Select Case DataType
Case ccsDate
Result = CCParseDate(Value, CurrentFormat)
Case ccsBoolean
Result = CCParseBoolean(Value, CurrentFormat)
Case ccsInteger
Result = CCParseInteger(Value, CurrentFormat)
Case ccsFloat
Result = CCParseFloat(Value, CurrentFormat)
Case ccsText, ccsMemo
Result = CStr(Value)
End Select
If Err.Number <> 0 Then _
mParseError = True
On Error Goto 0
StringToType = Result
End Function
Public Function TypeToString(DataType, Value, Format)
Dim CurrentFormat
Dim Result
Dim VarDataType
Dim CurrentDataType
VarDataType = VarType(Value)
Select Case VarDataType
Case vbInteger, vbLong, vbByte:
CurrentDataType = ccsInteger
Case vbSingle, vbDouble, vbCurrency, vbDecimal:
CurrentDataType = ccsFloat
Case vbDate:
CurrentDataType = ccsDate
Case vbBoolean:
CurrentDataType = ccsBoolean
Case vbString:
CurrentDataType = ccsText
Case vbArray, vbDataObject, vbVariant, vbError, vbObject, vbNull:
Err.Raise 1057, "Type mismatch"
End Select
If DataType = ccsMemo AND CurrentDataType = ccsText Then _
CurrentDataType = ccsMemo
If (VarDataType <> vbEmpty) AND (CurrentDataType <> DataType) Then _
Err.Raise 1057, "Type mismatch"
If IsEmpty(Format) Then
Select Case DataType
Case ccsDate
CurrentFormat = mDateFormat
Case ccsBoolean
CurrentFormat = mBooleanFormat
Case ccsInteger
CurrentFormat = mIntegerFormat
Case ccsFloat
CurrentFormat = mFloatFormat
End Select
Else
CurrentFormat = Format
End If
Select Case DataType
Case ccsDate
Result = CCFormatDate(Value, CurrentFormat)
Case ccsBoolean
Result = CCFormatBoolean(Value, CurrentFormat)
Case ccsInteger
Result = CCFormatNumber(Value, CurrentFormat)
Case ccsFloat
Result = CCFormatNumber(Value, CurrentFormat)
Case ccsText, ccsMemo
Result = CStr(Value)
End Select
TypeToString = Result
End Function
End Class
'End clsConverter Class
'clsRunTimeMessages Class @0-E0F50F10
Class clsRunTimeMessages
Private mMessages
Private Sub Class_Initialize()
Set mMessages = Server.CreateObject("Scripting.Dictionary")
mMessages.Add "IncorrectFormat", "Der Wert im Feld {FieldName} ist nicht gültig. Benutzen Sie folgendes Format: {Format}."
mMessages.Add "IncorrectValue", "Im Feld {FieldName} wurde kein gültiger Wert eingegeben."
mMessages.Add "RequiredField", "Sie müssen im Feld {FieldName} einen Wert eingeben."
mMessages.Add "CustomOperationError_MissingParameters", "Es fehlen einer oder mehrere Parameter für UPDATE/DELETE. Die Einstellungen sind nicht ausreichend."
mMessages.Add "UploadingTempFolderError", "Fehler beim Upload der im Feld {FieldName} angegebenen Datei in das temporäre Verzeichnis. Fehler-Beschreibung: {Error}."
mMessages.Add "GridPageSizeError", "(CCS06) Falsche Seitengröße."
mMessages.Add "GridPageNumberError", "Falsche Seitennummer."
mMessages.Add "DatabaseCommandError", "Datenbankfehler beim Ausführen des Kommandos."
mMessages.Add "OperationError", "{Operation} kann nicht ausgeführt werden. Einer oder mehrere Parameter sind nicht spezifiziert."
End Sub
Function GetMessage(MsgID, Params)
Dim Result, I
Result = ""
If mMessages.Exists(MsgID) Then
Result = mMessages(MsgID)
If IsArray(Params) Then
For I = 0 To UBound(Params) Step 2
Result = Replace(Result, "{" & Params(I) & "}", Params(I+1))
Next
End If
End If
GetMessage = Result
End Function
Private Sub Class_Terminate()
Set mMessages = Nothing
End Sub
End Class
'End clsRunTimeMessages Class
'clsStringBuffer @0-0A3F192B
Class clsStringBuffer
Private incremetRate
Private itemCount
Private items
Private Sub Class_Initialize()
incremetRate = 50
itemCount = 0
ReDim items(incremetRate)
End Sub
Public Sub Append(ByVal strValue)
If itemCount > UBound(items) Then
ReDim Preserve items(UBound(items) + incremetRate)
End If
items(itemCount) = strValue
itemCount = itemCount + 1
End Sub
Public Function ToString()
ToString = Join(items, "")
End Function
End Class
'End clsStringBuffer
%>