<% '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 %>