{ษออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออป บ บ บ Sibyl Portable Component Classes บ บ บ บ Copyright (C) 1995,97 SpeedSoft Germany, All rights reserved. บ บ บ ศออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออผ} Unit DBBase; Interface Uses Dos,SysUtils,Classes,Forms,Dialogs,DbLayer; Type TField=Class; TDataSet=Class; TDataSource=Class; ESQLError=Class(Exception); TDataChange=(dePositionChanged,deDataBaseChanged,deTableNameChanged); TDataChangeEvent=Procedure(Sender:TObject;event:TDataChange) Of Object; TDataLink=Class(TComponent) Private FDataSource:TDataSource; FOnDataChange:TDataChangeEvent; Procedure SetDataSource(NewValue:TDataSource); Procedure Notification(AComponent:TComponent;Operation:TOperation);Override; Procedure DataChange(event:TDataChange); Protected Procedure SetupComponent;Override; Public Destructor Destroy;Override; Property DataSource:TDataSource Read FDataSource Write SetDataSource; Property OnDataChange:TDataChangeEvent Read FOnDataChange Write FOnDataChange; End; TTableDataLink=Class(TDataLink) Private Function GetColRowField(Col,Row:LongInt):TField; Function GetNameRowField(Name:String;Row:LongInt):TField; Function GetFieldCount:LongInt; Function GetFieldName(Index:LongInt):String; Protected Procedure SetupComponent;Override; Public Property Fields[Col,Row:LongInt]:TField Read GetColRowField; Property FieldsFromColumnName[Col:String;Row:LongInt]:TField Read GetNameRowField; Property FieldCount:LongInt Read GetFieldCount; Property FieldNames[Index:LongInt]:String read GetFieldName; End; TFieldDataLink=Class(TDataLink) Private FFieldName:PString; Procedure SetFieldName(Const NewValue:String); Function GetFieldName:String; Function GetField:TField; Protected Procedure SetupComponent;Override; Public Destructor Destroy;Override; Property FieldName:String Read GetFieldName Write SetFieldName; Property field:TField Read GetField; End; TDataSource=Class(TComponent) Private FDataSet:TDataSet; FOnDataChange:TDataChangeEvent; Procedure SetDataSet(NewValue:TDataSet); Procedure Notification(AComponent:TComponent;Operation:TOperation);Override; Protected Procedure SetupComponent;Override; Procedure DataChange(event:TDataChange);Virtual; Public Destructor Destroy;Override; Published Property DataSet:TDataSet Read FDataSet Write SetDataSet; Property OnDataChange:TDataChangeEvent Read FOnDataChange Write FOnDataChange; End; TFieldType=(ftUnknown,ftString,ftSmallInt,ftInteger,ftWord,ftBoolean, ftFloat,ftCurrency,ftBCD,ftDate,ftTime,ftDateTime,ftBytes, ftVarBytes,ftAutoInc,ftBlob,ftMemo,ftGraphic,ftFmtMemo, ftTypedBinary,ftOLE); EDataBaseError=Class(Exception); TFieldDefs=Class; TFieldDef=Class; TOnFieldChange=Procedure(Sender:TField) Of Object; TField=Class Private FSize:Longword; //store size of datatype (floatfield!) FValue:Pointer; FValueLen:LongWord; FDataType:TFieldType; FDataSet:TDataSet; FFieldDef:TFieldDef; FRequired:Boolean; FRow:LongInt; FCol:LongInt; FReadOnly:Boolean; FOnChange:TOnFieldChange; Procedure FreeMemory; Procedure GetMemory(Size:Longint); Function GetFieldName:String; Function GetIsNull:Boolean; Procedure SetNewValue(Var NewValue;NewLen:LongInt); Function GetAsVariant:Variant;Virtual; Procedure SetAsVariant(NewValue:Variant);Virtual; Function GetIsIndexField:Boolean; Function GetCanModify:Boolean; Function GetReadOnly:Boolean; Protected Procedure SetAsValue(Var Value;Len:LongInt);Virtual; Function GetAsString:String;Virtual; Procedure SetAsString(Const NewValue:String);Virtual; Function GetAsAnsiString:AnsiString;Virtual; Procedure SetAsAnsiString(NewValue:AnsiString);Virtual; Function GetAsBoolean:Boolean;Virtual; Procedure SetAsBoolean(NewValue:Boolean);Virtual; Function GetAsDateTime:TDateTime;Virtual; Procedure SetAsDateTime(NewValue:TDateTime);Virtual; Function GetAsFloat:Extended;Virtual; Procedure SetAsFloat(Const NewValue:Extended);Virtual; Function GetAsInteger:LongInt;Virtual; Procedure SetAsInteger(NewValue:LongInt);Virtual; Procedure AccessError(Const TypeName:String);Virtual; Procedure CheckInactive; Public Destructor Destroy;Override; Procedure Clear;Virtual; Procedure Assign(Field:TField); Procedure SetData(Buffer:Pointer); Property IsNull:Boolean Read GetIsNull; Property ValueLen:LongWord Read FValueLen; Property DataType:TFieldType Read FDataType; Property Required:Boolean Read FRequired Write FRequired; Property Row:LongInt read FRow write FRow; Property Value:Variant read GetAsVariant write SetAsVariant; Property IsIndexField:Boolean read GetIsIndexField; Property CanModify:Boolean read GetCanModify; Property DataSet:TDataSet read FDataSet; Property DataSize:LongWord read FValueLen; Property ReadOnly:boolean read GetReadOnly write FReadOnly; Property Index:LongInt read FCol; Published Property FieldName:String Read GetFieldName; Property AsString:String Read GetAsString Write SetAsString; Property AsAnsiString:AnsiString Read GetAsAnsiString Write SetAsAnsiString; Property AsBoolean:Boolean Read GetAsBoolean Write SetAsBoolean; Property AsDateTime:TDateTime Read GetAsDateTime Write SetAsDateTime; Property AsFloat:Extended Read GetAsFloat Write SetAsFloat; Property AsInteger:LongInt Read GetAsInteger Write SetAsInteger; Property OnChange:TOnFieldChange read FOnChange write FOnChange; End; TFieldClass=Class Of TField; TStringField=Class(TField) Protected Function GetAsString:String;Override; Procedure SetAsString(Const NewValue:String);Override; Function GetAsAnsiString:AnsiString;Override; Procedure SetAsAnsiString(NewValue:AnsiString);Override; Function GetAsBoolean:Boolean;Override; Procedure SetAsBoolean(NewValue:Boolean);Override; Function GetAsDateTime:TDateTime;Override; Function GetAsFloat:Extended;Override; Procedure SetAsFloat(Const NewValue:Extended);Override; Function GetAsInteger:LongInt;Override; Procedure SetAsInteger(NewValue:LongInt);Override; Function GetAsVariant:Variant;Override; Procedure SetAsVariant(NewValue:Variant);Override; Public Property Value:String Read GetAsString write SetAsString; End; TSmallintField=Class(TField) Protected Function GetAsBoolean:Boolean;Override; Procedure SetAsBoolean(NewValue:Boolean);Override; Function GetAsString:String;Override; Procedure SetAsString(Const NewValue:String);Override; Function GetAsAnsiString:AnsiString;Override; Procedure SetAsAnsiString(NewValue:AnsiString);Override; Function GetAsSmallint:Integer;Virtual; Procedure SetAsSmallInt(NewValue:Integer);Virtual; Function GetAsFloat:Extended;Override; Procedure SetAsFloat(Const NewValue:Extended);Override; Function GetAsInteger:LongInt;Override; Procedure SetAsInteger(NewValue:LongInt);Override; Function GetAsVariant:Variant;Override; Procedure SetAsVariant(NewValue:Variant);Override; Public Property Value:Integer Read GetAsSmallint Write SetAsSmallInt; End; TIntegerField=Class(TField) Protected Function GetAsBoolean:Boolean;Override; Procedure SetAsBoolean(NewValue:Boolean);Override; Function GetAsString:String;Override; Procedure SetAsString(Const NewValue:String);Override; Function GetAsAnsiString:AnsiString;Override; Procedure SetAsAnsiString(NewValue:AnsiString);Override; Function GetAsFloat:Extended;Override; Procedure SetAsFloat(Const NewValue:Extended);Override; Function GetAsInteger:LongInt;Override; Procedure SetAsInteger(NewValue:LongInt);Override; Function GetAsVariant:Variant;Override; Procedure SetAsVariant(NewValue:Variant);Override; Public Property Value:LongInt Read GetAsInteger Write SetAsInteger; End; TAutoIncField=Class(TIntegerField) End; TBooleanField=Class(TField) Protected Function GetAsBoolean:Boolean;Override; Procedure SetAsBoolean(NewValue:Boolean);Override; Function GetAsString:String;Override; Procedure SetAsString(Const NewValue:String);Override; Function GetAsAnsiString:AnsiString;Override; Procedure SetAsAnsiString(NewValue:AnsiString);Override; Function GetAsFloat:Extended;Override; Procedure SetAsFloat(Const NewValue:Extended);Override; Function GetAsInteger:LongInt;Override; Procedure SetAsInteger(NewValue:LongInt);Override; Function GetAsVariant:Variant;Override; Procedure SetAsVariant(NewValue:Variant);Override; Public Property Value:Boolean Read GetAsBoolean Write SetAsBoolean; End; TFloatField=Class(TField) Private FPrecision:Longint; Procedure SetPrecision(Value:Longint); Protected Function GetAsString:String;Override; Procedure SetAsString(Const NewValue:String);Override; Function GetAsAnsiString:AnsiString;Override; Procedure SetAsAnsiString(NewValue:AnsiString);Override; Function GetAsFloat:Extended;Override; Procedure SetAsFloat(Const NewValue:Extended);Override; Function GetAsInteger:LongInt;Override; Procedure SetAsInteger(NewValue:LongInt);Override; Function GetAsVariant:Variant;Override; Procedure SetAsVariant(NewValue:Variant);Override; Public Constructor Create; Property Value:Extended Read GetAsFloat Write SetAsFloat; Property Precision:Longint Read FPrecision Write SetPrecision; End; TCurrencyField=Class(TFloatField) Public Constructor Create; End; TDateField=Class(TField) Private FDisplayFormat:PString; Private Function GetDisplayFormat:String; Procedure SetDisplayFormat(Const NewValue:String); Protected Function GetAsString:String;Override; Procedure SetAsString(Const NewValue:String);Override; Function GetAsAnsiString:AnsiString;Override; Procedure SetAsAnsiString(NewValue:AnsiString);Override; Function GetAsFloat:Extended;Override; Function GetAsDateTime:TDateTime;Override; Procedure SetAsDateTime(NewValue:TDateTime);Override; Function GetAsVariant:Variant;Override; Procedure SetAsVariant(NewValue:Variant);Override; Destructor Destroy;Override; Public Property Value:TDateTime Read GetAsDateTime Write SetAsDateTime; Property DisplayFormat:String read GetDisplayFormat write SetDisplayFormat; End; TTimeField=Class(TField) Private FDisplayFormat:PString; Private Function GetDisplayFormat:String; Procedure SetDisplayFormat(Const NewValue:String); Protected Function GetAsString:String;Override; Procedure SetAsString(Const NewValue:String);Override; Function GetAsAnsiString:AnsiString;Override; Procedure SetAsAnsiString(NewValue:AnsiString);Override; Function GetAsFloat:Extended;Override; Function GetAsDateTime:TDateTime;Override; Procedure SetAsDateTime(NewValue:TDateTime);Override; Function GetAsVariant:Variant;Override; Procedure SetAsVariant(NewValue:Variant);Override; Destructor Destroy;Override; Public Property Value:TDateTime Read GetAsDateTime Write SetAsDateTime; Property DisplayFormat:String read GetDisplayFormat write SetDisplayFormat; End; TDateTimeField=Class(TField) Private FDisplayFormat:PString; Private Function GetDisplayFormat:String; Procedure SetDisplayFormat(Const NewValue:String); Protected Function GetAsString:String;Override; Procedure SetAsString(Const NewValue:String);Override; Function GetAsAnsiString:AnsiString;Override; Procedure SetAsAnsiString(NewValue:AnsiString);Override; Function GetAsFloat:Extended;Override; Function GetAsDateTime:TDateTime;Override; Procedure SetAsDateTime(NewValue:TDateTime);Override; Function GetAsVariant:Variant;Override; Procedure SetAsVariant(NewValue:Variant);Override; Destructor Destroy;Override; Public Property Value:TDateTime Read GetAsDateTime Write SetAsDateTime; Property DisplayFormat:String read GetDisplayFormat write SetDisplayFormat; End; TBlobField=Class(TField) Protected Function GetAsString:String;Override; Function GetAsAnsiString:AnsiString;Override; Public Procedure LoadFromStream(Stream:TStream); Property Value:Pointer Read FValue; End; TMemoField=Class(TField) Protected Function GetAsString:String;Override; Function GetAsAnsiString:AnsiString;Override; Procedure SetAsAnsiString(NewValue:AnsiString);Override; Public Property Value:AnsiString Read GetAsAnsiString write SetAsAnsiString; End; TGraphicField=Class(TBlobField) Protected Function GetAsString:String;Override; End; TFieldList=Class(TList) //List Of Fields (TField entries) Public Procedure Clear;Override; End; TFieldDef=Class Private FFields:TList; FOwner:TFieldDefs; FName:String; FRequired:Boolean; FSize:Longword; FPrecision:LongInt; FDataType:TFieldType; FFieldNo:Longint; FPrimaryKey:Boolean; FForeignKey:PString; FTypeName:PString; Function GetFieldClass:TFieldClass; Function GetPrimaryKey:Boolean; Procedure SetPrimaryKey(NewValue:Boolean); Function GetForeignKey:String; Procedure SetForeignKey(Const NewValue:String); Function GetTypeName:String; Procedure SetTypeName(Const NewValue:String); Public Constructor Create(aOwner:TFieldDefs; Const aName:String; aDataType:TFieldType; aSize:Longword; aRequired:Boolean; aFieldNo:Longint); Destructor Destroy;Override; Function CreateField(Owner:TComponent):TField; Public Property Fields:TList Read FFields; Property DataType:TFieldType Read FDataType; Property FieldClass:TFieldClass Read GetFieldClass; Property FieldNo:Longint Read FFieldNo; Property Name:String Read FName; Property TypeName:String Read GetTypeName write SetTypeName; Property Precision:Longint Read FPrecision Write FPrecision; Property Required:Boolean Read FRequired; Property Size:Longword Read FSize Write FSize; Property PrimaryKey:Boolean read GetPrimaryKey write FPrimaryKey; Property ForeignKey:String read GetForeignKey write SetForeignKey; End; TFieldDefs=Class Private FDataSet:TDataSet; FItems:TList; Function Rows:Longint; Function GetCount:Longint; Function GetItem(Index:Longint):TFieldDef; Public Constructor Create(DataSet:TDataSet); Destructor Destroy;Override; Procedure Clear; Function Add(Const Name:String; DataType:TFieldType; Size:Longint; Required:Boolean):TFieldDef; Procedure Update; Procedure Assign(FieldDefs: TFieldDefs); Function Find(Const Name: string): TFieldDef; Function IndexOf(Const Name: string): LongInt; Public Property Count:Longint Read GetCount; Property Items[Index:Longint]:TFieldDef Read GetItem; default End; TDataSetNotifyEvent=Procedure(DataSet:TDataSet) Of Object; {$M+} TLocateOptions=Set Of (loCaseInsensitive,loPartialKey); {$M-} {$M+} TIndexOptions = Set of (ixPrimary, ixUnique, ixDescending, ixCaseInsensitive, ixExpression); {$M-} TDataSet=Class(TComponent) Private FCurrentRow:LongInt; FCurrentField:LongInt; FRowIsInserted:Boolean; FFieldDefs:TFieldDefs; FActive:Boolean; FOpened:Boolean; FDBProcs:TDBProcs; FServer:PString; FDataBase:PString; FDataSetLocked:Boolean; FRefreshOnLoad:Boolean; FSelect:TStrings; FDataChangeLock:Boolean; FMaxRows:LongInt; FBeforeOpen:TDataSetNotifyEvent; FAfterOpen:TDataSetNotifyEvent; FBeforeClose:TDataSetNotifyEvent; FAfterClose:TDataSetNotifyEvent; FBeforeInsert:TDataSetNotifyEvent; FAfterInsert:TDataSetNotifyEvent; FBeforePost:TDataSetNotifyEvent; FAfterPost:TDataSetNotifyEvent; FBeforeCancel:TDataSetNotifyEvent; FAfterCancel:TDataSetNotifyEvent; FBeforeDelete:TDataSetNotifyEvent; FAfterDelete:TDataSetNotifyEvent; FReadOnly:Boolean; Private Function GetBOF:Boolean; Function GetEOF:Boolean; Function GetField(Index:LongInt):TField; Function GetFieldCount:LongInt; Function GetFieldName(Index:LongInt):String; Function GetFieldType(Index:LongInt):TFieldType; Procedure SetCurrentField(NewValue:LongInt); Procedure SetCurrentRow(NewValue:LongInt); Procedure UpdateField(field:TField;OldValue:Pointer;OldValueLen:LongInt); Function GetFieldFromColumnName(ColumnName:String):TField; Procedure CheckRequiredFields; Procedure SetFieldDefs(NewValue:TFieldDefs); Procedure DesignerNotification(Var DNS:TDesignerNotifyStruct); Function IsTable:Boolean; Protected Procedure SetupComponent;Override; Procedure Loaded;Override; Procedure DataChange(event:TDataChange);Virtual; Procedure CheckInactive;Virtual; Procedure SetActive(NewValue:Boolean);Virtual; Procedure SetDataBaseName(Const NewValue:String);Virtual; Function GetDataBaseName:String;Virtual; Procedure SetServer(Const NewValue:String);Virtual; Function GetServer:String;Virtual; Function GetMaxRows:LongInt;Virtual; Function GetResultColRow(Col,Row:LongInt):TField;Virtual; Procedure CommitInsert(Commit:Boolean);Virtual; Function UpdateFieldSelect(Field:TField):Boolean;Virtual; Function GetFieldClass(FieldType:TFieldType):TFieldClass;Virtual; Procedure InsertCurrentFields; Procedure RemoveCurrentFields; Procedure QueryTable;Virtual; Procedure DoOpen;Virtual; Procedure DoClose;Virtual; Procedure DoPost;Virtual; Procedure DoCancel;Virtual; Procedure DoInsert;Virtual; Procedure DoDelete;Virtual; Property DataSetLocked:Boolean read FDataSetLocked write FDataSetLocked; Public Destructor Destroy;Override; Function WriteSCUResource(Stream:TResourceStream):Boolean;Override; Procedure ReadSCUResource(Const ResName:TResourceName;Var Data;DataLen:LongInt);Override; Procedure Open; Procedure Close; Procedure First; Procedure Last; Procedure Next; Procedure Prior; Procedure MoveBy(Distance:LongInt); Procedure Refresh; Procedure Post;Virtual; Procedure Cancel;Virtual; Procedure Insert;Virtual; Procedure Append;Virtual; Procedure Delete;Virtual; Procedure GetFieldNames(List:TStrings); Procedure GetDataSources(List:TStrings);Virtual; Procedure GetStoredProcNames(List:TStrings);Virtual; Procedure RefreshTable;Virtual; Procedure AppendRecord(Const values:Array Of Const); Procedure SetFields(Const values:Array Of Const); Procedure InsertRecord(Const Values:Array Of Const);Virtual; Function FieldByName(Const FieldName:String):TField; Function FindField(Const FieldName:String):TField; Function FindFirst: Boolean; Function FindLast: Boolean; Function FindNext: Boolean; Function FindPrior: Boolean; Procedure GetFieldList(List:TList;Const FieldNames:String); Function Locate(Const KeyFields:String;Const KeyValues:Array Of Const; Options:TLocateOptions):Boolean;Virtual; Public Property Bof:Boolean Read GetBOF; Property Eof:Boolean Read GetEOF; Property FieldCount:LongInt Read GetFieldCount; Property Fields[Index:LongInt]:TField Read GetField; Property FieldDefs:TFieldDefs read FFieldDefs write SetFieldDefs; Property FieldNames[Index:LongInt]:String Read GetFieldName; Property FieldTypes[Index:LongInt]:TFieldType Read GetFieldType; Property CurrentField:LongInt Read FCurrentField Write SetCurrentField; Property CurrentRow:LongInt Read FCurrentRow Write SetCurrentRow; Property RowInserted:Boolean Read FRowIsInserted write FRowIsInserted; Property FieldFromColumnName[ColumnName:String]:TField Read GetFieldFromColumnName; Property DataChangeLock:Boolean Read FDataChangeLock Write FDataChangeLock; Property MaxRows:LongInt read GetMaxRows; Property RecordCount:Longint read GetMaxRows; Property RecNo:Longint read FCurrentRow; Property DataBaseName:String Read GetDataBaseName Write SetDataBaseName; Published Property Active:Boolean Read FActive Write SetActive; Property Server:String Read GetServer Write SetServer; Property DataBase:String Read GetDataBaseName Write SetDataBaseName; Property ReadOnly:Boolean read FReadOnly write FReadOnly; Property BeforeOpen:TDataSetNotifyEvent Read FBeforeOpen Write FBeforeOpen; Property AfterOpen:TDataSetNotifyEvent Read FAfterOpen Write FAfterOpen; Property BeforeClose:TDataSetNotifyEvent Read FBeforeClose Write FBeforeClose; Property AfterClose:TDataSetNotifyEvent Read FAfterClose Write FAfterClose; Property BeforeInsert:TDataSetNotifyEvent Read FBeforeInsert Write FBeforeInsert; Property AfterInsert:TDataSetNotifyEvent Read FAfterInsert Write FAfterInsert; Property BeforePost:TDataSetNotifyEvent Read FBeforePost Write FBeforePost; Property AfterPost:TDataSetNotifyEvent Read FAfterPost Write FAfterPost; Property BeforeCancel:TDataSetNotifyEvent Read FBeforeCancel Write FBeforeCancel; Property AfterCancel:TDataSetNotifyEvent Read FAfterCancel Write FAfterCancel; Property BeforeDelete:TDataSetNotifyEvent Read FBeforeDelete Write FBeforeDelete; Property AfterDelete:TDataSetNotifyEvent Read FAfterDelete Write FAfterDelete; End; TLockType=(ltReadLock,ltWriteLock); TIndexDefs=Class; TIndexDef=Class Private FOwner: TIndexDefs; FName:PString; FFields:PString; FOptions:TIndexOptions; Function GetFields:String; Function GetName:String; Public Constructor Create(Owner:TIndexDefs;Const Name, Fields:String; Options:TIndexOptions); Destructor Destroy; override; Public Property Fields:String read GetFields; Property Name:String read GetName; Property Options: TIndexOptions read FOptions; End; TIndexDefs=Class Private FDataSet:TDataSet; FItems:TList; FUpdated: Boolean; Function GetCount:LongInt; Function GetItem(Index:LongInt): TIndexDef; Public Constructor Create(DataSet:TDataSet); Destructor Destroy;Override; Function Add(Const Name,Fields:String;Options:TIndexOptions):TIndexDef; Procedure Assign(IndexDefs:TIndexDefs); Procedure Clear; Function FindIndexForFields(Const Fields:String):TIndexDef; Function GetIndexForFields(Const Fields:String;CaseInsensitive:Boolean):TIndexDef; Function IndexOf(Const Name:String):LongInt; Procedure Update; Public Property Count:LongInt read GetCount; Property Items[Index:LongInt]:TIndexDef read GetItem;default; Property Updated:Boolean read FUpdated write FUpdated; End; TTable=Class(TDataSet) Private FTableName:PString; FMasterSource:TDataSource; FTempMasterSource:TDataSource; FMasterFields:PString; FServants:TList; //Servants that are connected With This FDataTypes:TStringList; FIndexDefs:TIndexDefs; FIndexFieldMap:TList; Private Function GetPassword:String; Function GetUserId:String; Procedure SetPassword(NewValue:String); Procedure SetUserId(NewValue:String); Procedure SetTableName(NewValue:String); Function GetTableName:String; Procedure SetTableLock(LockType:TLockType;Lock:Boolean); Procedure SetMasterSource(NewValue:TDataSource); Function GetMasterFields:String; Procedure SetMasterFields(Const NewValue:String); Procedure ConnectServant(Servant:TTable;Connect:Boolean); Procedure CloseStmt; Procedure GetNames(List:TStrings;Const Name:String); Procedure GetKeys(List:TStrings;Primary:Boolean); Function GetIndexFieldCount:LongInt; Function GetIndexField(Index:LongInt):TField; Procedure SetIndexField(Index:LongInt;NewValue:TField); Function GetIndexDefs:TIndexDefs; Protected Procedure SetupComponent;Override; Procedure SetActive(NewValue:Boolean);Override; Function GetResultColRow(Col,Row:LongInt):TField;Override; Procedure CommitInsert(Commit:Boolean);Override; Function UpdateFieldSelect(Field:TField):Boolean;Override; Procedure DataChange(event:TDataChange);Override; Procedure QueryTable;Override; Procedure DoOpen;Override; Procedure DoClose;Override; Procedure DoDelete;Override; Procedure DoCancel;Override; Procedure DoPost;Override; Procedure Loaded;Override; Procedure UpdateLinkList(Const PropertyName:String;LinkList:TList);Override; Public Procedure UpdateIndexDefs;Virtual; Procedure UpdateFieldDefs; Destructor Destroy;Override; Procedure RefreshTable;Override; Function WriteSCUResource(Stream:TResourceStream):Boolean;Override; Procedure ReadSCUResource(Const ResName:TResourceName;Var Data;DataLen:LongInt);Override; Procedure GetDataSources(List:TStrings);Override; Procedure GetStoredProcNames(List:TStrings);Override; Procedure LockTable(LockType:TLockType);Virtual; Procedure UnlockTable(LockType:TLockType);Virtual; Procedure GetPrimaryKeys(List:TStrings);Virtual; Procedure GetTableNames(List:TStrings);Virtual; Procedure AddIndex(Const Name:String;Fields:String;Options:TIndexOptions);Virtual; Procedure DeleteIndex(Const Name: string);Virtual; Procedure CreateTable;Virtual; Procedure DeleteTable;Virtual; Procedure EmptyTable;Virtual; Function FindKey(Const KeyValues:Array of Const):Boolean;Virtual; Procedure GetIndexNames(List: TStrings);Virtual; Procedure RenameTable(NewTableName:String);Virtual; Procedure GetViewNames(List:TStrings);Virtual; Procedure GetSystemTableNames(List:TStrings);Virtual; Procedure GetSynonymNames(List:TStrings);Virtual; Procedure GetDataTypes(List:TStrings);Virtual; Procedure GetForeignKeys(List:TStrings);Virtual; Function DataType2Name(DataType:TFieldType):String; Public Property IndexDefs:TIndexDefs read GetIndexDefs; Property IndexFieldCount:LongInt read GetIndexFieldCount; Property IndexFields[Index:LongInt]:TField read GetIndexField write SetIndexField; Published Property TableName:String Read GetTableName Write SetTableName; Property Password:String Read GetPassword Write SetPassword; Property UserId:String Read GetUserId Write SetUserId; Property MasterSource:TDataSource Read FMasterSource Write SetMasterSource; Property MasterFields:String Read GetMasterFields Write SetMasterFields; End; TQuery=Class(TTable) Private Property TableName; Property MasterFields; Property MasterSource; Property ReadOnly; Procedure SetSQL(NewValue:TStrings); Protected Procedure SetupComponent;Override; Public Procedure RefreshTable;Override; Function WriteSCUResource(Stream:TResourceStream):Boolean;Override; Procedure ReadSCUResource(Const ResName:TResourceName;Var Data;DataLen:LongInt);Override; Published Property SQL:TStrings Read FSelect Write SetSQL; End; TParams = Class; TParamType = (ptUnknown, ptInput, ptOutput, ptInputOutput, ptResult, ptResultSet); TParam = Class Private FParamList: TParams; FData: Variant; FName:PString; FDataType: TFieldType; FNull: Boolean; FBound: Boolean; FParamType: TParamType; FResultNTS:CString; FResultLongInt:LongInt; FResultSmallInt:SmallInt; FResultExtended:Extended; FResultDate:Record Year:Word; Month:Word; Day:Word; End; FResultTime:Record Hour:WORD; Minute:WORD; Second:WORD; End; FResultDateTime:Record Year:Word; Month:Word; Day:Word; Hour:WORD; Minute:WORD; Second:WORD; Fraction:LongWord; End; FOutLen:SQLINTEGER; Private Procedure SetAsBCD(Value: Currency); Procedure SetAsBoolean(Value: Boolean); Procedure SetAsCurrency(Value:Extended); Procedure SetAsDate(Value: TDateTime); Procedure SetAsDateTime(Value: TDateTime); Procedure SetAsFloat(Const Value:Extended); Procedure SetAsInteger(Value: Longint); Procedure SetAsString(const Value: string); Procedure SetAsSmallInt(Value: LongInt); Procedure SetAsTime(Value: TDateTime); Procedure SetAsVariant(Value: Variant); Procedure SetAsWord(Value: LongInt); Function GetName:String; Procedure SetName(Const NewValue:String); Protected Function GetAsBCD: Currency; Function GetAsBoolean: Boolean; Function GetAsDateTime: TDateTime; Function GetAsFloat:Extended; Function GetAsInteger: Longint; Function GetAsString: string; Function GetAsVariant: Variant; Function IsEqual(Value: TParam): Boolean; Procedure SetDataType(Value: TFieldType); Procedure SetText(Const Value:String); Public Constructor Create(AParamList: TParams; AParamType: TParamType); Destructor Destroy;Override; Procedure Assign(Param: TParam); Procedure AssignField(Field: TField); Procedure AssignFieldValue(Field:TField;Const Value: Variant); Procedure Clear; Public Property AsBCD: Currency read GetAsBCD write SetAsBCD; Property AsBoolean: Boolean read GetAsBoolean write SetAsBoolean; Property AsCurrency:Extended read GetAsFloat write SetAsCurrency; Property AsDate: TDateTime read GetAsDateTime write SetAsDate; Property AsDateTime: TDateTime read GetAsDateTime write SetAsDateTime; Property AsFloat:Extended read GetAsFloat write SetAsFloat; Property AsInteger: LongInt read GetAsInteger write SetAsInteger; Property AsSmallInt: LongInt read GetAsInteger write SetAsSmallInt; Property AsString:String read GetAsString write SetAsString; Property AsTime: TDateTime read GetAsDateTime write SetAsTime; Property AsWord: LongInt read GetAsInteger write SetAsWord; Property Bound: Boolean read FBound write FBound; Property DataType: TFieldType read FDataType write SetDataType; Property IsNull: Boolean read FNull; Property Name:String read GetName write SetName; Property ParamType: TParamType read FParamType write FParamType; Property Text:String read GetAsString write SetText; Property Value: Variant read GetAsVariant write SetAsVariant; End; TParams=Class Private FItems: TList; Function GetParam(Index: Word): TParam; Function GetParamValue(Const ParamName:String):Variant; Procedure SetParamValue(Const ParamName:String;Const Value: Variant); Public Constructor Create;Virtual; Destructor Destroy;Override; Procedure AddParam(Value: TParam); Procedure RemoveParam(Value: TParam); Function CreateParam(FldType:TFieldType;Const ParamName:String;ParamType: TParamType): TParam; Function Count:LongInt; Procedure Clear; Function IsEqual(Value:TParams): Boolean; Function ParamByName(Const Value:String): TParam; Property Items[Index: Word]: TParam read GetParam;default; Property ParamValues[Const ParamName:String]: Variant read GetParamValue write SetParamValue; End; TStoredProc=Class(TTable) Private FPrepared:Boolean; FParams:TParams; FProcName:String; Function GetParamCount:Word; Procedure SetPrepared(NewValue:Boolean); Procedure SetParams(NewValue:TParams); Procedure SetStoredProcName(NewValue:String); Property TableName; Property MasterSource; Property MasterFields; Property ReadOnly; Protected Procedure Loaded;Override; Procedure DoOpen;Override; Procedure DoClose;Override; Function UpdateFieldSelect(field:TField):Boolean;Override; Public Constructor Create(AOwner: TComponent);Override; Destructor Destroy;Override; Procedure Insert;Override; Procedure Delete;Override; Procedure InsertRecord(Const Values:Array Of Const);Override; Procedure CopyParams(Value:TParams); Procedure ExecProc; Function ParamByName(Const Value:String):TParam; Procedure Prepare; Procedure UnPrepare; Procedure SetDefaultParams; Property ParamCount:Word read GetParamCount; Property StmtHandle:SQLHStmt read FDBProcs.ahstmt; Property Prepared: Boolean read FPrepared write SetPrepared; Property Params:TParams read FParams write SetParams; Published Property StoredProcName:String read FProcName write SetStoredProcName; End; Function Field2String(field:TField):String; Function ExtractFieldName(Const Fields:String;Var Pos:LongInt):String; Procedure DatabaseError(Const Message:String); Procedure SQLError(Const Message:String); Implementation Type TGraphicHeader=Record Count:Word; { Fixed at 1 } HType:Word; { Fixed at $0100 } Size:Longint; { Size not including header } End; Const SQLProcessCount:LongWord=0; Procedure EnterSQLProcessing; Begin Screen.Cursor:=crSQLWait; inc(SQLProcessCount); End; Procedure LeaveSQLProcessing; Begin If SQLProcessCount>0 Then dec(SQLProcessCount); If SQLProcessCount=0 Then Screen.Cursor:=crDefault; End; Procedure DatabaseError(Const Message:String); Begin SQLProcessCount:=0; LeaveSQLProcessing; Raise EDataBaseError.Create(Message); End; Procedure SQLError(Const Message:String); Begin SQLProcessCount:=0; LeaveSQLProcessing; Raise ESQLError.Create(Message); End; { ษอออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออป บ บ บ Speed-Pascal/2 Version 2.0 บ บ บ บ Speed-Pascal Component Classes (SPCC) บ บ บ บ This section: TDataLink Class Implementation บ บ บ บ (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! บ บ บ ศอออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออผ } Procedure TDataLink.SetDataSource(NewValue:TDataSource); Begin If NewValue=FDataSource Then Exit; If FDataSource<>Nil Then FDataSource.Notification(Self,opRemove); FDataSource:=NewValue; If FDataSource<>Nil Then FDataSource.FreeNotification(Self); DataChange(deDataBaseChanged); End; Procedure TDataLink.DataChange(event:TDataChange); Begin If OnDataChange<>Nil Then OnDataChange(Self,event); End; Procedure TDataLink.Notification(AComponent:TComponent;Operation:TOperation); Begin Inherited Notification(AComponent,Operation); If AComponent=TComponent(FDataSource) Then If Operation=opRemove Then Begin FDataSource:=Nil; DataChange(deDataBaseChanged); End; End; Destructor TDataLink.Destroy; Begin If FDataSource<>Nil Then FDataSource.Notification(Self,opRemove); FDataSource:=Nil; DataChange(deDataBaseChanged); Inherited Destroy; End; Procedure TDataLink.SetupComponent; Begin Inherited SetupComponent; Name:='DataLink'; If Owner<>Nil Then SetDesigning(Owner.Designed); End; { ษอออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออป บ บ บ Speed-Pascal/2 Version 2.0 บ บ บ บ Speed-Pascal Component Classes (SPCC) บ บ บ บ This section: TTableDataLink Class Implementation บ บ บ บ (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! บ บ บ ศอออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออผ } Function TTableDataLink.GetColRowField(Col,Row:LongInt):TField; Begin Result:=Nil; If ((FDataSource=Nil)Or(FDataSource.DataSet=Nil)) Then Exit; Result:=FDataSource.DataSet.GetResultColRow(Col,Row); End; Function TTableDataLink.GetNameRowField(Name:String;Row:LongInt):TField; Var Col:LongInt; S:String; T:LongInt; Label Ok; Begin Result:=Nil; If ((FDataSource=Nil)Or(FDataSource.DataSet=Nil)) Then Exit; UpcaseStr(Name); For T:=0 To FDataSource.DataSet.FieldCount-1 Do Begin S:=FDataSource.DataSet.FieldNames[T]; UpcaseStr(S); If S=Name Then Begin Col:=T; Goto Ok; End; End; Exit; Ok: Result:=FDataSource.DataSet.GetResultColRow(Col,Row); End; Procedure TTableDataLink.SetupComponent; Begin Inherited SetupComponent; Name:='TableDataLink'; End; Function TTableDataLink.GetFieldCount:LongInt; Begin Result:=0; If ((FDataSource=Nil)Or(FDataSource.DataSet=Nil)) Then Exit; Result:=FDataSource.DataSet.FieldCount; End; Function TTableDataLink.GetFieldName(Index:LongInt):String; Begin Result:=''; If ((FDataSource=Nil)Or(FDataSource.DataSet=Nil)) Then Exit; Result:=FDataSource.DataSet.FieldNames[Index]; End; { ษอออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออป บ บ บ Speed-Pascal/2 Version 2.0 บ บ บ บ Speed-Pascal Component Classes (SPCC) บ บ บ บ This section: TFieldDataLink Class Implementation บ บ บ บ (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! บ บ บ ศอออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออผ } Procedure TFieldDataLink.SetFieldName(Const NewValue:String); Begin If GetFieldName=NewValue Then exit; AssignStr(FFieldName,NewValue); DataChange(deDataBaseChanged); End; Function TFieldDataLink.GetFieldName:String; Begin Result:=FFieldName^; End; Procedure TFieldDataLink.SetupComponent; Begin AssignStr(FFieldName,''); Inherited SetupComponent; Name:='FieldDataLink'; End; Function TFieldDataLink.GetField:TField; Var T:LongInt; S,s1:String; Begin Result:=Nil; S:=GetFieldName; If ((FDataSource=Nil)Or(FDataSource.DataSet=Nil)Or(S='')) Then Exit; UpcaseStr(S); For T:=0 To FDataSource.DataSet.FieldCount-1 Do Begin s1:=FDataSource.DataSet.FieldNames[T]; UpcaseStr(s1); If S=s1 Then Begin Result:=FDataSource.DataSet.Fields[T]; Exit; End; End; End; Destructor TFieldDataLink.Destroy; Begin AssignStr(FFieldName,''); Inherited Destroy; End; { ษอออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออป บ บ บ Speed-Pascal/2 Version 2.0 บ บ บ บ Speed-Pascal Component Classes (SPCC) บ บ บ บ This section: TDataSource Class Implementation บ บ บ บ (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! บ บ บ ศอออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออผ } //This tables DataSource changes, notify All Servants linked With MasterSource Procedure NotifyServants(Table:TTable); Var T:LongInt; Servant:TTable; Begin If Table.FServants<>Nil Then Begin //notify All Servants that their MasterSource Is invalid For T:=0 To Table.FServants.Count-1 Do Begin Servant:=Table.FServants[T]; Servant.FMasterSource:=Nil; If ((Servant.ComponentState*[csReading]=[])And(Not Servant.FDataSetLocked)) Then Servant.RefreshTable; End; Table.FServants.Clear; End; End; Procedure TDataSource.SetDataSet(NewValue:TDataSet); Var Table,Servant:TTable; T:LongInt; Begin If FDataSet<>Nil Then Begin If FDataSet Is TTable Then Begin If Not (NewValue Is TTable) Then NotifyServants(TTable(FDataSet)) Else If NewValue<>FDataSet Then Begin //New DataSet Is also A Table //Link All Servants Of This Table To the New one Table:=TTable(FDataSet); If Table.FServants<>Nil Then Begin For T:=0 To Table.FServants.Count-1 Do Begin Servant:=Table.FServants[T]; TTable(NewValue).ConnectServant(Servant,True); End; Table.FServants.Clear; End; End; End; FDataSet.Notification(Self,opRemove); End; FDataSet:=NewValue; If FDataSet<>Nil Then FDataSet.FreeNotification(Self); DataChange(deDataBaseChanged); End; Destructor TDataSource.Destroy; Begin If FDataSet Is TTable Then NotifyServants(TTable(FDataSet)); If FDataSet<>Nil Then FDataSet.Notification(Self,opRemove); FDataSet:=Nil; Inherited Destroy; End; Procedure TDataSource.SetupComponent; Begin Include(ComponentState, csHandleLinks); Inherited SetupComponent; // Include(DesignerState,dsDetail); Name:='DataSource'; End; Procedure TDataSource.DataChange(event:TDataChange); Var T:LongInt; Link:TDataLink; FLinkList:TList; Begin FLinkList:=FreeNotifyList; If FLinkList<>Nil Then For T:=0 To FLinkList.Count-1 Do Begin Link:=FLinkList.Items[T]; If Link Is TDataLink Then Link.DataChange(event); End; End; Procedure TDataSource.Notification(AComponent:TComponent;Operation:TOperation); Begin Inherited Notification(AComponent,Operation); If AComponent=TComponent(FDataSet) Then If Operation=opRemove Then Begin FDataSet:=Nil; DataChange(deDataBaseChanged); If OnDataChange<>Nil Then OnDataChange(Self,deDataBaseChanged); End; End; { ษอออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออป บ บ บ Speed-Pascal/2 Version 2.0 บ บ บ บ Speed-Pascal Component Classes (SPCC) บ บ บ บ This section: TField Class Implementation บ บ บ บ (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! บ บ บ ศอออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออผ } Function TField.GetIsIndexField:Boolean; Var s,s1,s2:String; t:LongInt; IndexDef:TIndexDef; Begin Result:=False; If not (FDataSet Is TTable) Then exit; s:=FieldName; UpcaseStr(s); For t:=0 To TTable(FDataSet).IndexDefs.Count-1 Do Begin IndexDef:=TTable(FDataSet).IndexDefs[t]; s1:=IndexDef.Fields; UpcaseStr(s1); While pos(';',s1)<>0 Do Begin s2:=Copy(s1,1,pos(';',s1)-1); Delete(s1,1,pos(';',s1)); If s=s2 Then Begin Result:=True; exit; End; End; If s=s1 Then Result:=True; End; End; Function TField.GetReadOnly:Boolean; Begin Result:=FReadOnly Or FDataSet.ReadOnly; End; Function TField.GetCanModify:Boolean; Begin Result:=not ReadOnly; End; Procedure TField.SetData(Buffer:Pointer); Begin If ReadOnly Then DataBaseError('Cannot modify a readonly field !'); If FValueLen > 0 Then Begin If FValue<>Nil Then FreeMem(FValue,FValueLen); FValue:=Nil; If Buffer<>Nil Then Begin GetMem(FValue,FValueLen); Move(Buffer^,FValue^,FValueLen); End; End; End; Procedure TField.Assign(Field:TField); Begin If ReadOnly Then DataBaseError('Cannot modify a readonly field !'); If Field=Nil Then Begin Clear; If FValueLen<>0 Then FreeMem(FValue,FValueLen); FValueLen:=0; FValue:=Nil; exit; End; Value:=Field.Value; End; Function TField.GetAsVariant:Variant; Begin AccessError('Variant'); End; Procedure TField.SetAsVariant(NewValue:Variant); Begin AccessError('Variant'); End; Function TField.GetFieldName:String; Begin If FFieldDef <> Nil Then Result := FFieldDef.Name Else Result:=''; End; Function TField.GetIsNull:Boolean; Begin Result:=FValue=Nil; End; Destructor TField.Destroy; Begin If FValue<>Nil Then If FValueLen>0 Then FreeMem(FValue,FValueLen); FValueLen:=0; FValue:=Nil; Inherited Destroy; End; Procedure TField.Clear; Var OldValue:Pointer; OldValueLen:LongInt; Begin //SetNewValue(Nil,0); OldValue := FValue; OldValueLen := FValueLen; FValueLen := 0; FValue := Nil; FDataSet.UpdateField(Self,OldValue,OldValueLen); {wo wird der alte Speicher wieder freigegeben???} End; Procedure TField.FreeMemory; Begin If (FValue <> Nil) And (FValueLen > 0) Then FreeMem(FValue,FValueLen); FValueLen := 0; FValue := Nil; End; Procedure TField.GetMemory(Size:Longint); Begin FValueLen := Size; GetMem(FValue,FValueLen); End; Procedure TField.AccessError(Const TypeName:String); Begin DatabaseError('Invalid type conversion to '+TypeName+' in field: '+FieldName); End; Procedure TField.CheckInactive; Begin If FDataSet <> Nil Then FDataSet.CheckInactive; End; {$HINTS OFF} Procedure TField.SetAsValue(Var Value;Len:LongInt); Begin SetNewValue(Value,Len); End; Function TField.GetAsString:String; Begin AccessError('String'); End; Procedure TField.SetAsString(Const NewValue:String); Begin AccessError('String'); End; Function TField.GetAsAnsiString:AnsiString; Begin AccessError('AnsiString'); End; Procedure TField.SetAsAnsiString(NewValue:AnsiString); Begin AccessError('AnsiString'); End; Function TField.GetAsBoolean:Boolean; Begin AccessError('Boolean'); End; Procedure TField.SetAsBoolean(NewValue:Boolean); Begin AccessError('Boolean'); End; Function TField.GetAsDateTime:TDateTime; Begin AccessError('DateTime'); End; Procedure TField.SetAsDateTime(NewValue:TDateTime); Begin AccessError('DateTime'); End; Function TField.GetAsFloat:Extended; Begin AccessError('Float'); End; Procedure TField.SetAsFloat(Const NewValue:Extended); Begin AccessError('Float'); End; Function TField.GetAsInteger:LongInt; Begin AccessError('Integer'); End; Procedure TField.SetAsInteger(NewValue:LongInt); Begin AccessError('Integer'); End; {$HINTS ON} Procedure TField.SetNewValue(Var NewValue;NewLen:LongInt); Var OldValue:Pointer; OldValueLen:LongInt; Begin If ReadOnly Then DataBaseError('Cannot modify a readonly field !'); OldValue:=FValue; OldValueLen:=FValueLen; FValueLen:=NewLen; If FValueLen > 0 Then Begin GetMem(FValue,FValueLen); Move(NewValue,FValue^,FValueLen); End; FDataSet.UpdateField(Self,OldValue,OldValueLen); {wo wird der alte Speicher wieder freigegeben???} End; { ษอออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออป บ บ บ Speed-Pascal/2 Version 2.0 บ บ บ บ Speed-Pascal Component Classes (SPCC) บ บ บ บ This section: TStringField Class Implementation บ บ บ บ (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! บ บ บ ศอออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออผ } Function TStringField.GetAsVariant:Variant; Begin Result:=GetAsString; End; Procedure TStringField.SetAsVariant(NewValue:Variant); Begin SetAsString(NewValue); End; Function TStringField.GetAsString:String; Begin If FValue <> Nil Then Begin Result[0] := Chr(FValueLen); Move(FValue^,Result[1],Ord(Result[0])); If Result[Length(Result)]=#0 Then If length(Result)>0 Then Dec(Result[0]); End //Else Result:='NULL'; Else Result := ''; End; Procedure TStringField.SetAsString(Const NewValue:String); Var C:CString; Begin If NewValue <> '' Then Begin C:=NewValue; SetNewValue(C,Length(NewValue)+1); End Else Clear; End; Function TStringField.GetAsAnsiString:AnsiString; Begin If FValue<>Nil Then Result:=PChar(Value)^ Else Result:=''; End; Procedure TStringField.SetAsAnsiString(NewValue:AnsiString); Begin If PChar(NewValue) = Nil Then NewValue:=#0; SetNewValue(PChar(NewValue)^,length(PChar(NewValue)^)+1) End; Function TStringField.GetAsBoolean:Boolean; Var S:String; Begin S:=GetAsString; UpcaseStr(S); If ((S='TRUE')Or(S='YES')Or(S='1')) Then Result:=True Else Result:=False End; Procedure TStringField.SetAsBoolean(NewValue:Boolean); Var S:String; Begin If NewValue Then S:='True' Else S:='False'; SetAsString(S); End; Function TStringField.GetAsDateTime:TDateTime; Begin Result:=StrToDateTime(GetAsString); End; Function TStringField.GetAsFloat:Extended; Begin Result:=StrToFloat(GetAsString); End; Procedure TStringField.SetAsFloat(Const NewValue:Extended); Begin SetAsString(FloatToStr(NewValue)); End; Function TStringField.GetAsInteger:LongInt; Begin Result:=StrToInt(GetAsString); End; Procedure TStringField.SetAsInteger(NewValue:LongInt); Begin SetAsString(tostr(NewValue)); End; { ษอออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออป บ บ บ Speed-Pascal/2 Version 2.0 บ บ บ บ Speed-Pascal Component Classes (SPCC) บ บ บ บ This section: TSmallintField Class Implementation บ บ บ บ (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! บ บ บ ศอออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออผ } Function TSmallIntField.GetAsVariant:Variant; Begin Result:=GetAsSmallInt; End; Procedure TSmallIntField.SetAsVariant(NewValue:Variant); Begin SetAsSmallInt(NewValue); End; Function TSmallintField.GetAsString:String; Begin If FValue<>Nil Then Result:=tostr(Integer(FValue^)) Else Result:=''; End; Procedure TSmallintField.SetAsString(Const NewValue:String); Var I,C:Integer; Begin If NewValue <> '' Then Begin Val(NewValue,I,C); If C=0 Then SetNewValue(I,SizeOf(Integer)); End Else Clear; End; Function TSmallintField.GetAsAnsiString:AnsiString; Begin Result:=GetAsString; End; Procedure TSmallintField.SetAsAnsiString(NewValue:AnsiString); Begin SetAsString(NewValue); End; Function TSmallintField.GetAsBoolean:Boolean; Var I:Integer; Begin I:=GetAsInteger; Result:=I<>0; End; Procedure TSmallintField.SetAsBoolean(NewValue:Boolean); Begin If NewValue Then SetAsInteger(1) Else SetAsInteger(0); End; Function TSmallintField.GetAsSmallint:Integer; Begin If FValue<>Nil Then Result:=Integer(FValue^) Else AccessError('Smallint'); End; Procedure TSmallintField.SetAsSmallInt(NewValue:Integer); Begin SetNewValue(NewValue,SizeOf(Integer)); End; Function TSmallintField.GetAsFloat:Extended; Begin If FValue<>Nil Then Result:=Integer(FValue^) Else AccessError('Float'); End; Procedure TSmallintField.SetAsFloat(Const NewValue:Extended); Begin SetAsSmallInt(Round(NewValue)); End; Function TSmallintField.GetAsInteger:LongInt; Begin If FValue<>Nil Then Result:=Integer(FValue^) Else AccessError('Integer'); End; Procedure TSmallintField.SetAsInteger(NewValue:LongInt); Begin SetAsSmallInt(NewValue); End; { ษอออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออป บ บ บ Speed-Pascal/2 Version 2.0 บ บ บ บ Speed-Pascal Component Classes (SPCC) บ บ บ บ This section: TIntegerField Class Implementation บ บ บ บ (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! บ บ บ ศอออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออผ } Function TIntegerField.GetAsVariant:Variant; Begin Result:=GetAsInteger; End; Procedure TIntegerField.SetAsVariant(NewValue:Variant); Begin SetAsInteger(NewValue); End; Function TIntegerField.GetAsString:String; Begin If FValue<>Nil Then Result:=tostr(LongInt(FValue^)) Else Result:=''; End; Procedure TIntegerField.SetAsString(Const NewValue:String); Var I:LongInt; C:Integer; Begin If NewValue <> '' Then Begin Val(NewValue,I,C); If C=0 Then SetNewValue(I,SizeOf(LongInt)) Else AccessError('String'); End Else Clear; End; Function TIntegerField.GetAsAnsiString:AnsiString; Begin Result:=GetAsString; End; Procedure TIntegerField.SetAsAnsiString(NewValue:AnsiString); Begin SetAsString(NewValue); End; Function TIntegerField.GetAsBoolean:Boolean; Var I:Integer; Begin I:=GetAsInteger; Result:=I<>0; End; Procedure TIntegerField.SetAsBoolean(NewValue:Boolean); Begin If NewValue Then SetAsInteger(1) Else SetAsInteger(0); End; Function TIntegerField.GetAsFloat:Extended; Begin If FValue<>Nil Then Result:=LongInt(FValue^) Else AccessError('Float'); End; Procedure TIntegerField.SetAsFloat(Const NewValue:Extended); Begin SetAsInteger(Round(NewValue)); End; Function TIntegerField.GetAsInteger:LongInt; Begin If FValue<>Nil Then Result:=LongInt(FValue^) Else AccessError('Integer'); End; Procedure TIntegerField.SetAsInteger(NewValue:LongInt); Begin SetNewValue(NewValue,SizeOf(LongInt)); End; { ษอออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออป บ บ บ Speed-Pascal/2 Version 2.0 บ บ บ บ Speed-Pascal Component Classes (SPCC) บ บ บ บ This section: TBooleanField Class Implementation บ บ บ บ (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! บ บ บ ศอออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออผ } Function TBooleanField.GetAsVariant:Variant; Begin Result:=GetAsBoolean; End; Procedure TBooleanField.SetAsVariant(NewValue:Variant); Begin SetAsBoolean(NewValue); End; Function TBooleanField.GetAsString:String; Begin If FValue<>Nil Then Begin If Boolean(FValue^) Then Result:='True' Else Result:='False'; End Else Result:=''; End; Procedure TBooleanField.SetAsString(Const NewValue:String); Var s:String; Begin If NewValue <> '' Then Begin s:=NewValue; UpcaseStr(s); If ((s='TRUE')Or(s='YES')Or(s='T')Or(s='Y')Or(s='1')) Then SetAsBoolean(True) Else SetAsBoolean(False); End Else Clear; End; Function TBooleanField.GetAsAnsiString:AnsiString; Begin Result:=GetAsString; End; Procedure TBooleanField.SetAsAnsiString(NewValue:AnsiString); Begin SetAsString(NewValue); End; Function TBooleanField.GetAsBoolean:Boolean; Begin If FValue<>Nil Then Begin Result := Boolean(FValue^); End Else Result:=False; End; Procedure TBooleanField.SetAsBoolean(NewValue:Boolean); Begin SetNewValue(NewValue,SizeOf(Boolean)) End; Function TBooleanField.GetAsFloat:Extended; Begin If FValue<>Nil Then Begin If Boolean(FValue^) Then Result := 1 Else Result := 0; End Else AccessError('Float'); End; Procedure TBooleanField.SetAsFloat(Const NewValue:Extended); Begin SetAsInteger(round(NewValue)); End; Function TBooleanField.GetAsInteger:LongInt; Begin If FValue<>Nil Then Begin If Boolean(FValue^) Then Result := 1 Else Result := 0; End Else AccessError('Integer'); End; Procedure TBooleanField.SetAsInteger(NewValue:LongInt); Begin If NewValue = 0 Then SetAsBoolean(False) Else SetAsBoolean(True); End; { ษอออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออป บ บ บ Speed-Pascal/2 Version 2.0 บ บ บ บ Speed-Pascal Component Classes (SPCC) บ บ บ บ This section: TFloatField Class Implementation บ บ บ บ (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! บ บ บ ศอออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออผ } Constructor TFloatField.Create; Begin Inherited Create; FPrecision := -1; End; Function TFloatField.GetAsVariant:Variant; Begin Result:=GetAsFloat; End; Procedure TFloatField.SetAsVariant(NewValue:Variant); Begin SetAsFloat(NewValue); End; Procedure TFloatField.SetPrecision(Value:Longint); Begin //If Value < 2 Then Value := 2; If Value > 15 Then Value := 15; FPrecision := Value; End; Function TFloatField.GetAsString:String; Var E:Extended; Begin If FValue <> Nil Then Begin E := GetAsFloat; If Precision >= 0 Then Begin Result := Format('%.'+ tostr(Precision) +'f',[E]); If Precision = 0 Then If pos('.',Result) > 0 Then SubStr(Result,1,pos('.',Result)-1); End Else Result := FloatToStr(E); End Else Result := ''; End; Procedure TFloatField.SetAsString(Const NewValue:String); Var E:Extended; C:Integer; p:Integer; aValue:String; Begin If NewValue <> '' Then Begin //replace , by . p := pos(',',NewValue); If p > 0 Then Begin aValue := NewValue; aValue[p] := '.'; Val(aValue,E,C); End Else Val(NewValue,E,C); If C=0 Then SetAsFloat(E) Else AccessError('String'); End Else Clear; End; Function TFloatField.GetAsAnsiString:AnsiString; Begin Result:=GetAsString; End; Procedure TFloatField.SetAsAnsiString(NewValue:AnsiString); Begin SetAsString(NewValue); End; Function TFloatField.GetAsFloat:Extended; Begin If FValue<>Nil Then Begin Case FSize Of 4:Result:=Single(FValue^); 8:Result:=Double(FValue^); 10:Result:=Extended(FValue^); Else AccessError('Float'); End; {Case} End //Else AccessError('Float'); Else Result := 0; End; Procedure TFloatField.SetAsFloat(Const NewValue:Extended); Var E:Extended; S:Single; D:Double; Begin Case FSize Of 4: Begin S:=NewValue; SetNewValue(S,SizeOf(Single)); End; 8: Begin D:=NewValue; SetNewValue(D,SizeOf(Double)); End; 10: Begin E:=NewValue; SetNewValue(E,SizeOf(Extended)); End; End; End; Function TFloatField.GetAsInteger:LongInt; Begin Result := Round(GetAsFloat); End; Procedure TFloatField.SetAsInteger(NewValue:LongInt); Var E:Extended; Begin E := NewValue; SetAsFloat(E); End; { ษอออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออป บ บ บ Speed-Pascal/2 Version 2.0 บ บ บ บ Speed-Pascal Component Classes (SPCC) บ บ บ บ This section: TCurrencyField Class Implementation บ บ บ บ (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! บ บ บ ศอออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออผ } Constructor TCurrencyField.Create; Begin Inherited Create; FPrecision := 2; End; { ษอออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออป บ บ บ Speed-Pascal/2 Version 2.0 บ บ บ บ Speed-Pascal Component Classes (SPCC) บ บ บ บ This section: TDateField Class Implementation บ บ บ บ (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! บ บ บ ศอออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออผ } Function TDateField.GetAsString:String; Var date:TDateTime; Begin If FValue <> Nil Then Begin date := GetAsDateTime; DateTimeToString(result,DisplayFormat,date); End Else Result := ''; End; Destructor TDateField.Destroy; Begin AssignStr(FDisplayFormat,''); Inherited Destroy; End; Function TDateField.GetDisplayFormat:String; Begin If FDisplayFormat=Nil Then Result:=ShortDateFormat Else Result:=FDisplayFormat^; End; Procedure TDateField.SetDisplayFormat(Const NewValue:String); Begin AssignStr(FDisplayFormat,NewValue); If FDataSet<>Nil Then FDataSet.DataChange(deDataBaseChanged); End; Function TDateField.GetAsVariant:Variant; Begin Result:=GetAsDateTime; End; Procedure TDateField.SetAsVariant(NewValue:Variant); Begin SetAsDateTime(NewValue); End; Procedure TDateField.SetAsString(Const NewValue:String); Var dt:TDateTime; Valid:Boolean; Begin If NewValue <> '' Then Begin Try dt:=StrToDate(NewValue); Valid:=True; Except Valid:=False; End; If Valid Then SetAsDateTime(dt); End Else Clear; End; Function TDateField.GetAsAnsiString:AnsiString; Begin Result:=GetAsString; End; Procedure TDateField.SetAsAnsiString(NewValue:AnsiString); Begin SetAsString(NewValue); End; Function TDateField.GetAsFloat:Extended; Begin If FValue<>Nil Then Result:=GetAsDateTime Else AccessError('Float'); End; Function TDateField.GetAsDateTime:TDateTime; Var date:TODBCDate; Begin If FValue<>Nil Then Begin date:=TODBCDate(FValue^); Result:=EncodeDate(date.Year,date.Month,date.Day); End Else AccessError('DateTime'); End; Procedure TDateField.SetAsDateTime(NewValue:TDateTime); Var R:TODBCDate; Begin DecodeDate(NewValue,R.Year,R.Month,R.Day); SetNewValue(R,SizeOf(R)); End; { ษอออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออป บ บ บ Speed-Pascal/2 Version 2.0 บ บ บ บ Speed-Pascal Component Classes (SPCC) บ บ บ บ This section: TTimeField Class Implementation บ บ บ บ (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! บ บ บ ศอออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออผ } Procedure RoundDecodeTime(Time: TDateTime; Var Hour, Min, Sec: Word); Var MSec:Word; Begin DecodeTime(Time, Hour, Min, Sec, MSec); If MSec > 500 Then Begin MSec := 0; inc(Sec); End; If Sec >= 60 Then Begin dec(Sec,60); inc(Min); End; If Min >= 60 Then Begin dec(Min,60); inc(Hour); End; End; Destructor TTimeField.Destroy; Begin AssignStr(FDisplayFormat,''); Inherited Destroy; End; Function TTimeField.GetDisplayFormat:String; Begin If FDisplayFormat=Nil Then Result:=LongTimeFormat Else Result:=FDisplayFormat^; End; Procedure TTimeField.SetDisplayFormat(Const NewValue:String); Begin AssignStr(FDisplayFormat,NewValue); If FDataSet<>Nil Then FDataSet.DataChange(deDataBaseChanged); End; Function TTimeField.GetAsVariant:Variant; Begin Result:=GetAsDateTime; End; Procedure TTimeField.SetAsVariant(NewValue:Variant); Begin SetAsDateTime(NewValue); End; Function TTimeField.GetAsString:String; Var Time:TDateTime; Begin If FValue<>Nil Then Begin Time:=GetAsDateTime; DateTimeToString(Result,DisplayFormat,Time); End Else Result:=''; End; Procedure TTimeField.SetAsString(Const NewValue:String); Var dt:TDateTime; Valid:Boolean; Begin If NewValue <> '' Then Begin Try dt:=StrToTime(NewValue); Valid:=True; Except Valid:=False; End; If Valid Then SetAsDateTime(dt); End Else Clear; End; Function TTimeField.GetAsAnsiString:AnsiString; Begin Result:=GetAsString; End; Procedure TTimeField.SetAsAnsiString(NewValue:AnsiString); Begin SetAsString(NewValue); End; Function TTimeField.GetAsFloat:Extended; Begin If FValue<>Nil Then Result:=GetAsDateTime Else AccessError('Float'); End; Function TTimeField.GetAsDateTime:TDateTime; Var Time:TODBCTime; Begin If FValue<>Nil Then Begin Time:=TODBCTime(FValue^); Result:=EncodeTime(Time.Hour,Time.Minute,Time.Second,0); End Else AccessError('DateTime'); End; Procedure TTimeField.SetAsDateTime(NewValue:TDateTime); Var R:TODBCTime; Begin RoundDecodeTime(NewValue,R.Hour,R.Minute,R.Second); SetNewValue(R,SizeOf(R)); End; { ษอออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออป บ บ บ Speed-Pascal/2 Version 2.0 บ บ บ บ Speed-Pascal Component Classes (SPCC) บ บ บ บ This section: TDateTimeField Class Implementation บ บ บ บ (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! บ บ บ ศอออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออผ } Destructor TDateTimeField.Destroy; Begin AssignStr(FDisplayFormat,''); Inherited Destroy; End; Function TDateTimeField.GetDisplayFormat:String; Begin If FDisplayFormat=Nil Then Result:=ShortDateFormat+' '+LongTimeFormat Else Result:=FDisplayFormat^; End; Procedure TDateTimeField.SetDisplayFormat(Const NewValue:String); Begin AssignStr(FDisplayFormat,NewValue); If FDataSet<>Nil Then FDataSet.DataChange(deDataBaseChanged); End; Function TDateTimeField.GetAsVariant:Variant; Begin Result:=GetAsDateTime; End; Procedure TDateTimeField.SetAsVariant(NewValue:Variant); Begin SetAsDateTime(NewValue); End; Function TDateTimeField.GetAsString:String; Var DateTime:TDateTime; Begin If FValue<>Nil Then Begin DateTime:=GetAsDateTime; DateTimeToString(result,DisplayFormat,DateTime); End Else Result:=''; End; Procedure TDateTimeField.SetAsString(Const NewValue:String); Var dt:TDateTime; Valid:Boolean; Begin If NewValue <> '' Then Begin Try dt:=StrToDateTime(NewValue); Valid:=True; Except Valid:=False; End; If Valid Then SetAsDateTime(dt); End Else Clear; End; Function TDateTimeField.GetAsAnsiString:AnsiString; Begin Result:=GetAsString; End; Procedure TDateTimeField.SetAsAnsiString(NewValue:AnsiString); Begin SetAsString(NewValue); End; Function TDateTimeField.GetAsFloat:Extended; Begin If FValue<>Nil Then Result:=GetAsDateTime Else AccessError('Float'); End; Function TDateTimeField.GetAsDateTime:TDateTime; Var dt:TODBCDateTime; Begin If FValue<>Nil Then Begin dt:=TODBCDateTime(FValue^); Result:=EncodeDate(dt.Date.Year,dt.Date.Month,dt.Date.Day) + EncodeTime(dt.Time.Hour,dt.Time.Minute,dt.Time.Second,0); End Else AccessError('DateTime'); End; Procedure TDateTimeField.SetAsDateTime(NewValue:TDateTime); Var R:TODBCDateTime; Begin DecodeDate(NewValue,R.Date.Year,R.Date.Month,R.Date.Day); RoundDecodeTime(NewValue,R.Time.Hour,R.Time.Minute,R.Time.Second); SetNewValue(R,SizeOf(R)); End; { ษอออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออป บ บ บ Speed-Pascal/2 Version 2.0 บ บ บ บ Speed-Pascal Component Classes (SPCC) บ บ บ บ This section: TBlobField Class Implementation บ บ บ บ (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! บ บ บ ศอออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออผ } Function TBlobField.GetAsString:String; Begin If FValue <> Nil Then Result := '[Blob]' Else Result := '[BLOB]'; End; Function TBlobField.GetAsAnsiString:AnsiString; Begin Result := GetAsString; End; Procedure TBlobField.LoadFromStream(Stream:TStream); Var prec:^Byte; Begin If Stream Is TStream Then Begin GetMem(prec, Stream.Size); Stream.Position := 0; Stream.Read(prec^,Stream.Size); SetAsValue(prec^, Stream.Size); FreeMem(prec, Stream.Size); End; End; { ษอออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออป บ บ บ Speed-Pascal/2 Version 2.0 บ บ บ บ Speed-Pascal Component Classes (SPCC) บ บ บ บ This section: TMemoField Class Implementation บ บ บ บ (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! บ บ บ ศอออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออผ } Function TMemoField.GetAsString:String; Begin If FValue <> Nil Then Result := '[Memo]' Else Result := '[MEMO]'; End; Function TMemoField.GetAsAnsiString:AnsiString; Begin If FValue = Nil Then Result := '' Else Result := PChar(FValue)^; End; Procedure TMemoField.SetAsAnsiString(NewValue:AnsiString); Begin If NewValue <> '' Then Begin SetNewValue(PChar(NewValue)^,length(PChar(NewValue)^)+1); End Else Clear; End; { ษอออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออป บ บ บ Speed-Pascal/2 Version 2.0 บ บ บ บ Speed-Pascal Component Classes (SPCC) บ บ บ บ This section: TGraphicField Class Implementation บ บ บ บ (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! บ บ บ ศอออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออผ } Function TGraphicField.GetAsString:String; Begin If FValue<>Nil Then Result:='[Graphic]' Else Result:='[GRAPHIC]'; End; { ษอออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออป บ บ บ Speed-Pascal/2 Version 2.0 บ บ บ บ Speed-Pascal Component Classes (SPCC) บ บ บ บ This section: TFieldList Class Implementation บ บ บ บ (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! บ บ บ ศอออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออผ } Procedure TFieldList.Clear; Var T:LongInt; field:TField; Begin For T:=0 To Count-1 Do Begin field:=Items[T]; field.Destroy; End; Inherited Clear; End; { ษอออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออป บ บ บ Speed-Pascal/2 Version 2.0 บ บ บ บ Speed-Pascal Component Classes (SPCC) บ บ บ บ This section: TIndexDef Class Implementation บ บ บ บ (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! บ บ บ ศอออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออผ } Function TIndexDef.GetName:String; Begin If FName<>Nil Then Result:=FName^ Else Result:=''; End; Function TIndexDef.GetFields:String; Begin If FFields<>Nil Then Result:=FFields^ Else Result:=''; End; Constructor TIndexDef.Create(Owner:TIndexDefs;Const Name, Fields:String;Options:TIndexOptions); Begin Inherited Create; If Owner <> Nil Then Begin Owner.FItems.Add(Self); FOwner:=Owner; End; AssignStr(FName,Name); AssignStr(FFields,Fields); FOptions:=Options; End; Destructor TIndexDef.Destroy; Begin If FOwner <> Nil Then FOwner.FItems.Remove(Self); AssignStr(FName,''); AssignStr(FFields,''); Inherited Destroy; End; { ษอออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออป บ บ บ Speed-Pascal/2 Version 2.0 บ บ บ บ Speed-Pascal Component Classes (SPCC) บ บ บ บ This section: TIndexDefs Class Implementation บ บ บ บ (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! บ บ บ ศอออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออผ } Function TIndexDefs.GetCount:LongInt; Begin Result:=FItems.Count; End; Function TIndexDefs.GetItem(Index:LongInt):TIndexDef; Begin Result:=TIndexDef(FItems[Index]); End; Constructor TIndexDefs.Create(DataSet:TDataSet); Begin Inherited Create; FDataSet:=DataSet; FItems.Create; End; Destructor TIndexDefs.Destroy; Begin Clear; FItems.Destroy; Inherited Destroy; End; Procedure TIndexDefs.Clear; Var IndexDef:TIndexDef; Begin While FItems.Count > 0 Do Begin IndexDef := TIndexDef(FItems[0]); IndexDef.Destroy; // auto removing from FItems End; End; Function TIndexDefs.Add(Const Name,Fields:String;Options:TIndexOptions):TIndexDef; Begin //...check valid Result.Create(Self, Name, Fields,Options); End; Procedure TIndexDefs.Assign(IndexDefs: TIndexDefs); Var IndexDef:TIndexDef; t:LongInt; Begin Clear; For t:=0 To IndexDefs.Count-1 Do Begin IndexDef:=IndexDefs.Items[t]; Add(IndexDef.Name,IndexDef.Fields,IndexDef.Options); End; End; Function TIndexDefs.FindIndexForFields(Const Fields:String):TIndexDef; Begin Result:=GetIndexForFields(Fields,False); If Result=Nil Then DataBaseError('No index for fields: '+Fields); End; Function TIndexDefs.GetIndexForFields(Const Fields:String;CaseInsensitive:Boolean):TIndexDef; Var t:LongInt; s,s1:String; Begin s:=Fields; If CaseInsensitive Then UpcaseStr(s); Result:=Nil; For t:=0 To Count-1 Do Begin s1:=Items[t].Fields; If CaseInsensitive Then UpcaseStr(s1); If s=s1 Then Begin Result:=Items[t]; exit; End; End; End; Function TIndexDefs.IndexOf(Const Name:String):LongInt; Var t:LongInt; Begin Result:=-1; For t:=0 To Count-1 Do If Items[t].Name=Name Then Begin Result:=t; exit; End; End; Procedure TIndexDefs.Update; Begin TTable(FDataSet).UpdateIndexDefs; End; { ษอออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออป บ บ บ Speed-Pascal/2 Version 2.0 บ บ บ บ Speed-Pascal Component Classes (SPCC) บ บ บ บ This section: TFieldDef Class Implementation บ บ บ บ (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! บ บ บ ศอออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออผ } Constructor TFieldDef.Create(aOwner:TFieldDefs; Const aName:String; aDataType:TFieldType; aSize:Longword; aRequired:Boolean; aFieldNo:Longint); Begin Inherited Create; If aOwner <> Nil Then Begin aFieldNo := aOwner.FItems.Add(Self); FOwner := aOwner; End; FName := aName; FDataType := aDataType; FSize := aSize; If aDataType = ftString Then Inc(FSize); FRequired := aRequired; FFieldNo := aFieldNo; FPrecision := -1; If FDataType In [ftWord,ftInteger,ftSmallInt] Then If not (FSize In [1,2,4]) Then FSize:=4; //LongInt If FDataType=ftFloat Then If not (FSize In [4,8,10]) Then FSize:=10; //Extended FFields.Create; End; Function TFieldDef.GetTypeName:String; Begin If FTypeName=Nil Then Begin Result:=''; If FOwner.FDataSet Is TTable Then Result:=TTable(FOwner.FDataSet).DataType2Name(FDataType); End Else Result:=FTypeName^; End; Procedure TFieldDef.SetTypeName(Const NewValue:String); Begin AssignStr(FTypeName,NewValue); End; Destructor TFieldDef.Destroy; Var i:Longint; Field:TField; Begin If FOwner <> Nil Then FOwner.FItems.Remove(Self); If FFields <> Nil Then Begin For i := 0 To FFields.Count-1 Do Begin Field := TField(FFields[i]); If Field <> Nil Then Field.Destroy; End; End; AssignStr(FForeignKey,''); AssignStr(FTypeName,''); FFields.Destroy; FFields := Nil; Inherited Destroy; End; Function TFieldDef.CreateField(Owner:TComponent):TField; Var FieldClass:TFieldClass; Begin FieldClass := GetFieldClass; If FieldClass = Nil Then DatabaseError('Unknown field type "'+Name+'"'); Result := FieldClass.Create; Try Result.FFieldDef := Self; Result.FRequired := Required; Result.FSize := Size; Result.FDataType := FDataType; If Result Is TFloatField Then Begin TFloatField(Result).FPrecision := Precision; If not (Size In [4,8]) Then Begin Size:=8; Result.FSize:=8; End; End; If FOwner <> Nil Then Result.FDataSet := FOwner.FDataSet; GetMem(Result.FValue,Size); Result.FValueLen := Size; Except; Result.Free; Raise; End; End; Function TFieldDef.GetFieldClass:TFieldClass; Begin Result := FOwner.FDataSet.GetFieldClass(FDataType); End; Function TFieldDef.GetPrimaryKey:Boolean; Var Keys:TStrings; t:LongInt; Begin If (Not (FOwner.FDataSet.IsTable)) Then DataBaseError('Cannot perform this action on a query or stored procedure'); Result:=False; If FOwner.FDataSet.Active Then Begin Keys.Create; TTable(FOwner.FDataSet).GetPrimaryKeys(Keys); For t:=0 To Keys.Count-1 Do If Keys[t]=Name Then Begin Keys.Destroy; Result:=True; exit; End; Keys.Destroy; End Else Result:=FPrimaryKey; End; Procedure TFieldDef.SetPrimaryKey(NewValue:Boolean); Begin If (Not (FOwner.FDataSet.IsTable)) Then DataBaseError('Cannot perform this action on a query or stored procedure'); FPrimaryKey:=NewValue; If FOwner.FDataSet.Active Then //Modify table definition Begin End; End; Function TFieldDef.GetForeignKey:String; Var Keys:TStrings; t:LongInt; s:String; Begin If (Not (FOwner.FDataSet.IsTable)) Then DataBaseError('Cannot perform this action on a query or stored procedure'); If FOwner.FDataSet.Active Then Begin Keys.Create; TTable(FOwner.FDataSet).GetForeignKeys(Keys); For t:=0 To Keys.Count-1 Do Begin s:=Keys[t]; If Pos('>',s)<>0 Then s[0]:=chr(pos('>',s)-1); If s=Name Then Begin Keys.Destroy; s:=Keys[t]; Delete(s,1,pos('>',s)); Result:=s; exit; End; End; Keys.Destroy; End Else Begin If FForeignKey<>Nil Then Result:=FForeignKey^ Else Result:=''; End; End; Procedure TFieldDef.SetForeignKey(Const NewValue:String); Begin If (Not (FOwner.FDataSet.IsTable)) Then DataBaseError('Cannot perform this action on a query or stored procedure'); AssignStr(FForeignKey,NewValue); If FOwner.FDataSet.Active Then //modify table definition Begin End; End; { ษอออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออป บ บ บ Speed-Pascal/2 Version 2.0 บ บ บ บ Speed-Pascal Component Classes (SPCC) บ บ บ บ This section: TFieldDefs Class Implementation บ บ บ บ (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! บ บ บ ศอออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออผ } Constructor TFieldDefs.Create(DataSet:TDataSet); Begin Inherited Create; FDataSet := DataSet; FItems.Create; End; Destructor TFieldDefs.Destroy; Begin Clear; FItems.Destroy; Inherited Destroy; End; Function TFieldDefs.Rows:LongInt; Var FieldDef:TFieldDef; Begin Result := 0; If Count = 0 Then Exit; FieldDef := Items[0]; Result := FieldDef.Fields.Count; End; Procedure TFieldDefs.Clear; Var FieldDef:TFieldDef; Begin While FItems.Count > 0 Do Begin FieldDef := TFieldDef(FItems[0]); FieldDef.Destroy; // auto removing from FItems End; End; Function TFieldDefs.GetCount:Longint; Begin Result := FItems.Count; End; Function TFieldDefs.GetItem(Index:Longint):TFieldDef; Begin Result := FItems[Index]; End; Function TFieldDefs.Add(Const Name:String; DataType:TFieldType; Size:Longint; Required:Boolean):TFieldDef; Begin //...check valid Result.Create(Self, Name, DataType, Size, Required, FItems.Count); End; Procedure TFieldDefs.Assign(FieldDefs: TFieldDefs); Var FieldDef:TFieldDef; t:LongInt; Begin Clear; For t:=0 To FieldDefs.Count-1 Do Begin FieldDef:=Items[t]; Add(FieldDef.Name,FieldDef.DataType,FieldDef.Size,FieldDef.Required); End; End; Function TFieldDefs.Find(const Name: string): TFieldDef; Var Index:LongInt; Begin Index:=IndexOf(Name); If Index=-1 Then SQLError('Field not found: '+Name) Else Result:=Items[Index]; End; Function TFieldDefs.IndexOf(const Name: string): LongInt; Var t:LongInt; Begin Result:=-1; For t:=0 To Count-1 Do If Items[t].Name=Name Then Begin Result:=t; exit; End; End; Procedure TFieldDefs.Update; Begin FDataSet.QueryTable; End; { ษอออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออป บ บ บ Speed-Pascal/2 Version 2.0 บ บ บ บ Speed-Pascal Component Classes (SPCC) บ บ บ บ This section: TDataSet Class Implementation บ บ บ บ (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! บ บ บ ศอออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออผ } Const DefaultFieldClasses:Array[TFieldType] Of TFieldClass= (TBlobField, {ftUnknown} TStringField, {ftString} TSmallintField, {ftSmallInt} TIntegerField, {ftInteger} TBlobField, {ftWord} TBlobField, {ftBoolean} TFloatField, {ftFloat} TCurrencyField, {ftCurrency} TBlobField, {ftBCD} TDateField, {ftDate} TTimeField, {ftTime} TDateTimeField, {ftDateTime} TBlobField, {ftBytes} TBlobField, {ftVarBytes} TAutoIncField, {ftAutoInc} TBlobField, {ftBlob} TMemoField, {ftMemo} TGraphicField, {ftGraphic} TMemoField, {ftFmtMemo} TBlobField, {ftTypedBinary} TBlobField {ftOLE} ); Procedure TDataSet.SetupComponent; Begin Include(ComponentState, csHandleLinks); AssignStr(FDataBase,''); AssignStr(FServer,''); Inherited SetupComponent; Name:='DataSet'; FFieldDefs.Create(Self); FSelect:=TStringList.Create; FCurrentRow:=-1; FCurrentField:=0; End; Destructor TDataSet.Destroy; Begin FFieldDefs.Destroy; FFieldDefs:=Nil; AssignStr(FServer,''); AssignStr(FDataBase,''); FSelect.Destroy; FSelect:=Nil; Inherited Destroy; End; Function TDataSet.GetFieldClass(FieldType:TFieldType):TFieldClass; Begin Result := DefaultFieldClasses[FieldType]; End; Procedure TDataSet.DesignerNotification(Var DNS:TDesignerNotifyStruct); Var AForm:TForm; Begin AForm := TForm(Owner); If AForm <> Nil Then Begin While (AForm.Designed) And (AForm.Owner <> Nil) Do Begin AForm := TForm(AForm.Owner); End; End; If AForm <> Nil Then If AForm Is TForm Then AForm.DesignerNotification(DNS); End; Function TDataSet.Locate(Const KeyFields:String;Const KeyValues:Array Of Const; Options:TLocateOptions):Boolean; Begin Result := False; //??? End; Procedure TDataSet.SetFieldDefs(NewValue:TFieldDefs); Begin FFieldDefs.Assign(NewValue); End; Procedure TDataSet.GetStoredProcNames(List:TStrings); Begin List.Clear; End; Procedure TDataSet.Open; Begin Active := True; End; Procedure TDataSet.Close; Begin Active := False; End; Procedure TDataSet.SetActive(NewValue:Boolean); Begin If FActive <> NewValue Then Begin FActive := NewValue; DataChange(deDataBaseChanged); End; End; Procedure TDataSet.SetCurrentRow(NewValue:LongInt); Begin MoveBy(NewValue-FCurrentRow); End; Procedure TDataSet.SetCurrentField(NewValue:LongInt); Begin If NewValue<0 Then NewValue:=0; If NewValue>FieldCount-1 Then NewValue:=FieldCount-1; FCurrentField:=NewValue; End; Function TDataSet.GetEOF:Boolean; Begin Result := GetResultColRow(0,FCurrentRow+1) = Nil; End; Function TDataSet.GetBOF:Boolean; Begin Result := FCurrentRow <= 0; End; Function TDataSet.GetMaxRows:LongInt; Begin Result := FMaxRows; If RowInserted Then inc(Result); End; Procedure TDataSet.Refresh; Begin DataChange(deDataBaseChanged); End; Procedure TDataSet.DataChange(event:TDataChange); Var I:LongInt; Source:TDataSource; FLinkList:TList; Begin If FDataChangeLock Then Exit; FLinkList:=FreeNotifyList; If FLinkList<>Nil Then For I:=0 To FLinkList.Count-1 Do Begin Source:=FLinkList.Items[I]; If Source Is TDataSource Then Begin Source.DataChange(event); If Source.OnDataChange<>Nil Then Source.OnDataChange(Source,event); End; End; End; Procedure TDataSet.First; Begin SetCurrentRow(0); End; Procedure TDataSet.Last; Begin SetCurrentRow(MaxRows-1); End; Procedure TDataSet.Next; Begin SetCurrentRow(FCurrentRow+1); End; Procedure TDataSet.Prior; Begin SetCurrentRow(FCurrentRow-1); End; Procedure TDataSet.MoveBy(Distance:LongInt); Var Field:TField; FieldDef:TFieldDef; Begin If Distance = 0 Then Exit; If FFieldDefs.Count = 0 Then exit; If FRowIsInserted Then CommitInsert(True); FCurrentRow := FCurrentRow + Distance; If FCurrentRow < 0 Then FCurrentRow := 0; If FCurrentRow >= MaxRows Then FCurrentRow := MaxRows-1; Field := GetResultColRow(0,FCurrentRow); FieldDef := FFieldDefs[0]; If FieldDef <> Nil Then Begin If FCurrentRow > FieldDef.Fields.Count-1 Then FCurrentRow := FieldDef.Fields.Count-1; If FCurrentRow < 0 Then FCurrentRow := 0; End; DataChange(dePositionChanged); End; Function TDataSet.WriteSCUResource(Stream:TResourceStream):Boolean; Var S:String; dll:String; P,p1:Pointer; len:LongInt; dbType:TDBTypes; dbOrd:LongInt; DriverName,Advanced,UID:String; Begin S:=Server; GetDBServerFromAlias(S,dll,dbType); dbOrd:=ord(dbType); len:=Length(S)+1+Length(dll)+1+4; GetMem(P,len); p1:=P; Move(S,p1^,Length(S)+1); Inc(p1,Length(S)+1); Move(dll,p1^,Length(dll)+1); inc(p1,length(dll)+1); Move(dbOrd,p1^,4); Result:=Stream.NewResourceEntry(rnDBServer,P^,len); FreeMem(P,len); If Not Result Then Exit; S:=DataBase; GetDBServerFromDBAlias(S,DriverName,Advanced,UID); len:=Length(S)+1+Length(Advanced)+1+length(UID)+1; GetMem(P,len); p1:=P; Move(S,p1^,Length(S)+1); Inc(p1,Length(S)+1); Move(Advanced,p1^,Length(Advanced)+1); Inc(p1,Length(Advanced)+1); Move(UID,p1^,Length(UID)+1); Result:=Stream.NewResourceEntry(rnDBDataBase,S,Length(S)+1); FreeMem(P,len); End; Procedure TDataSet.ReadSCUResource(Const ResName:TResourceName;Var Data;DataLen:LongInt); Var S,dll:String; B:^Byte; dbType:TDBTypes; Advanced,UID:String; Begin If ResName = rnDBServer Then Begin dbType:=ODBC; B:=@Data; Move(B^,S,B^+1); Inc(B,B^+1); Move(B^,dll,B^+1); If DataLen>length(S)+1+length(dll)+1 Then //Sibyl FP3 Begin inc(B,length(dll)+1); move(B^,dbType,sizeof(dbType)); End; AddServerAlias(S,dll,dbType); Server:=S; End; If ResName = rnDBDataBase Then Begin Advanced:=''; UID:=''; B:=@Data; Move(B^,S,B^+1); Inc(B,B^+1); If DataLen>length(S)+1 Then //Sibyl FP3 Begin Move(B^,Advanced,B^+1); Inc(B,B^+1); Move(B^,UID,B^+1); End; AddDataBaseAlias(S,Server,Advanced,UID); DataBase:=S; End; End; Function TDataSet.GetDataBaseName:String; Begin Result:=FDataBase^; End; Procedure TDataSet.SetDataBaseName(Const NewValue:String); Var Alias,Advanced,UID,DllName:String; DNS:TDesignerNotifyStruct; Begin If GetDataBaseName=NewValue Then Exit; If FOpened Then If GetDataBaseName<>'' Then Begin ErrorBox(LoadNLSStr(SCannotPerformDBAction)); Exit; End; AssignStr(FDataBase,NewValue); FreeDBProcs(FDBProcs); FDBProcs.DataBase:=NewValue; GetDBServerFromDBAlias(NewValue,Alias,Advanced,UID); If Alias<>'' Then If Alias<>Server Then Begin AssignStr(FServer, Alias); FDBProcs.AliasName:=Alias; End; If ComponentState*[csReading]=[] Then FDBProcs.UID:=UID Else If FDBProcs.UID='' Then FDBProcs.UID:=UID; GetDBServerFromAlias(FDBProcs.AliasName,DllName,FDBProcs.DBType); Case FDBProcs.DBType Of Native_mSQL: Begin If ComponentState*[csReading]=[] Then FDBProcs.Host:=Advanced Else If FDBProcs.Host='' Then FDBProcs.Host:=Advanced; End; End; If Self Is TTable Then If ComponentState*[csReading]=[] Then Begin TTable(Self).TableName:=''; TTable(Self).UserId:=''; TTable(Self).Password:=''; End; DNS.Sender := Self; DNS.Code := dncPropertyUpdate; DNS.return := 0; DesignerNotification(DNS); End; Function TDataSet.GetServer:String; Begin Result:=FServer^; End; Procedure TDataSet.SetServer(Const NewValue:String); Var WasLocked:Boolean; DllName:String; DNS:TDesignerNotifyStruct; Begin If GetServer=NewValue Then Exit; If FOpened Then Begin ErrorBox(LoadNLSStr(SCannotPerformDBAction)); Exit; End; FreeDBProcs(FDBProcs); AssignStr(FServer,NewValue); FDBProcs.AliasName:=NewValue; GetDBServerFromAlias(FDBProcs.AliasName,DllName,FDBProcs.DBType); WasLocked:=FDataSetLocked; FDataSetLocked:=True; AssignStr(FDataBase,''); If Self Is TTable Then AssignStr(TTable(Self).FTableName,''); FDataSetLocked:=WasLocked; If ComponentState*[csReading]=[] Then Begin FDBProcs.UID:=''; FDBProcs.Host:=''; End; DNS.Sender := Self; DNS.Code := dncPropertyUpdate; DNS.return := 0; DesignerNotification(DNS); End; Function TDataSet.GetFieldCount:LongInt; Begin Result:=FFieldDefs.Count; End; Function TDataSet.GetFieldName(Index:LongInt):String; Var FieldDef:TFieldDef; Begin Result:=''; If ((Index<0)Or(Index>FieldCount-1)) Then Exit; FieldDef:=FFieldDefs[Index]; Result:=FieldDef.Name; End; Function TDataSet.GetFieldType(Index:LongInt):TFieldType; Var FieldDef:TFieldDef; Begin Result:=ftUnknown; If ((Index<0)Or(Index>FieldCount-1)) Then Exit; FieldDef:=FFieldDefs[Index]; Result:=FieldDef.DataType; End; Function TDataSet.GetFieldFromColumnName(ColumnName:String):TField; Var Index:LongInt; T:LongInt; FieldDef:TFieldDef; S:String; Begin Result:=Nil; Index:=-1; UpcaseStr(ColumnName); For T:=0 To FFieldDefs.Count-1 Do Begin FieldDef:=FFieldDefs[T]; S:=FieldDef.Name; UpcaseStr(S); If S=ColumnName Then Begin Index:=T; break; End; End; If Index<>-1 Then Result:=Fields[Index]; End; Procedure TDataSet.CheckRequiredFields; Var Field:TField; i:Longint; Begin For i := 0 To FieldCount-1 Do Begin Field := GetResultColRow(i,FCurrentRow); If Field<>Nil Then If Field.Required And Field.IsNull Then Begin //Field.FocusControl; ErrorBox('Field '+ Field.FieldName +' is required'); DatabaseError('Field '+ Field.FieldName +' is required'); End; End; End; Function TDataSet.GetField(Index:LongInt):TField; Begin Result:=Nil; If ((Index<0)Or(Index>FieldCount-1)Or(FCurrentRow<0)) Then Exit; Result:=GetResultColRow(Index,FCurrentRow); End; Function TDataSet.GetResultColRow(Col,Row:LongInt):TField; Var FieldDef:TFieldDef; Begin Result := Nil; If Not FOpened Then Exit; If Row < 0 Then Exit; //Row does Not exist If Row >= GetMaxRows Then Exit; //Row does Not exist If (Col < 0) Or (Col >= FieldDefs.Count) Then Exit; {Column does Not exist} FieldDef := FieldDefs[Col]; If Row <= FieldDef.Fields.Count-1 Then Result := FieldDef.Fields.Items[Row]; End; Procedure TDataSet.AppendRecord(Const values:Array Of Const); Begin InsertRecord(values); End; Procedure TDataSet.SetFields(Const values:Array Of Const); Var T:LongInt; rec:TVarRec; field:TField; Begin Try FDataChangeLock:=True; For T:=0 To High(values) Do Begin If T>FieldCount-1 Then Exit; Field:=Fields[T]; If Field=Nil Then continue; rec:=TVarRec(values[T]); Case rec.VType Of vtInteger:field.AsInteger:=rec.VInteger; vtBoolean:field.AsBoolean:=rec.VBoolean; vtChar:field.AsString:=rec.VChar; vtExtended:field.AsFloat:=rec.VExtended^; vtString:field.AsString:=rec.VString^; vtPointer:; vtPChar:field.AsString:=rec.VPChar^; vtAnsiString:field.AsString:=AnsiString(rec.VAnsiString); End; {Case} End; Finally FDataChangeLock:=False; Post; End; End; Procedure TDataSet.InsertRecord(Const values:Array Of Const); Begin Try FDataChangeLock:=True; Insert; Finally FDataChangeLock:=False; End; SetFields(values); End; Function TDataSet.FieldByName(Const FieldName:String):TField; Begin Result:=FindField(FieldName); If Result=Nil Then DatabaseError('Field '+FieldName+' not found'); End; Function TDataSet.FindFirst:Boolean; Begin Result:=BOF; End; Function TDataSet.FindLast:Boolean; Begin Result:=EOF; End; Function TDataSet.FindNext:Boolean; Begin Result:=not EOF; End; Function TDataSet.FindPrior:Boolean; Begin Result:=not BOF; End; Function ExtractFieldName(Const Fields:String;Var Pos:LongInt):String; Var t:LongInt; Begin t:=Pos; While (t<=Length(Fields))And(Fields[t]<>';') Do Inc(t); Result:=Copy(Fields,Pos,t-Pos); If (t<=Length(Fields))And(Fields[t]=';') Then Inc(t); Pos:=t; End; Procedure TDataSet.GetFieldList(List:TList; const FieldNames: string); Var t:LongInt; Begin t:=1; While t<=Length(FieldNames) Do List.Add(FieldByName(ExtractFieldName(FieldNames,t))); End; Function TDataSet.FindField(Const FieldName:String):TField; Var T:LongInt; S,s1:String; Begin Result:=Nil; S:=FieldName; UpcaseStr(S); For T:=0 To FieldCount-1 Do Begin s1:=FieldNames[T]; UpcaseStr(s1); If S=s1 Then Begin Result:=Fields[T]; Exit; End; End; End; Procedure TDataSet.DoOpen; Begin FOpened := True; End; Procedure TDataSet.DoClose; Begin If FRowIsInserted Then CommitInsert(True); FMaxRows:=0; FCurrentRow := -1; FOpened := False; End; Procedure TDataSet.RefreshTable; Begin End; Procedure TDataSet.GetDataSources(List:TStrings); Begin List.Clear; End; Procedure TDataSet.GetFieldNames(List:TStrings); Var T:LongInt; Begin List.Clear; If FieldCount=0 Then Begin If ((Designed)And(Not FOpened)) Then Begin FActive:=True; DoOpen; If Not FOpened Then FActive:=False Else RefreshTable; End Else RefreshTable; End; For T:=0 To FieldCount-1 Do List.Add(FieldNames[T]); End; Procedure TDataSet.Delete; Begin If Not FOpened Then Exit; If (CurrentRow < 0) Or (CurrentRow >= RecordCount) Then exit; Try If FBeforeDelete <> Nil Then FBeforeDelete(Self); If FRowIsInserted Then CommitInsert(False) Else DoDelete; DataChange(deDataBaseChanged); If FAfterDelete <> Nil Then FAfterDelete(Self); Except Raise; End; End; Procedure TDataSet.DoDelete; Begin RemoveCurrentFields; End; Procedure TDataSet.Append; Begin Insert; End; Procedure TDataSet.Insert; Begin If Not FOpened Then Exit; Try If FBeforeInsert <> Nil Then FBeforeInsert(Self); If FRowIsInserted Then CommitInsert(True); DoInsert; DataChange(deDataBaseChanged); If FAfterInsert <> Nil Then FAfterInsert(Self); Except Raise; End; End; Procedure TDataSet.DoInsert; Begin If FCurrentRow < 0 Then FCurrentRow := 0; //empty table InsertCurrentFields; FRowIsInserted := True; End; Procedure TDataSet.InsertCurrentFields; Var Col,Row:LongInt; FieldDef:TFieldDef; Field:TField; Begin For Col := 0 To FFieldDefs.Count-1 Do Begin FieldDef := FFieldDefs[Col]; Field := FieldDef.CreateField(Nil); //Field.Clear; If Field.FValue<>Nil Then FreeMem(Field.FValue,Field.FValueLen); Field.FValue:=Nil; Field.FValueLen:=0; Field.FRow := FCurrentRow; Field.FCol := Col; FieldDef.Fields.Insert(FCurrentRow,Field); For Row := FCurrentRow+1 To FieldDef.Fields.Count-1 Do Begin Field := FieldDef.Fields[Row]; If Field <> Nil Then Inc(Field.FRow); End; End; End; Const Months:Array[1..12] Of String[4]=('Jan','Feb','Mar','Apr','May','Jun','Jul', 'Aug','Sep','Oct','Nov','Dec'); Function Field2String(field:TField):String; Var dt:TDateTime; Year,Month,Day,Hour,Min,Sec:Word; s,s1,s2:String; Begin If field.IsNull Then Begin Result:='NULL'; Exit; End; Case field.DataType Of ftDate: Begin dt:=field.GetAsDateTime; DecodeDate(dt,Year,Month,Day); If Field.FDataSet.FDBProcs.DBType=Native_mSQL Then Result:=tostr(Day)+'-'+Months[Month]+'-'+tostr(Year) Else Result:=tostr(Year)+'-'+tostr(Month)+'-'+tostr(Day); End; ftTime: Begin dt:=field.GetAsDateTime; RoundDecodeTime(dt,Hour,Min,Sec); If Field.FDataSet.FDBProcs.DBType=Native_mSQL Then Result:=tostr(Hour)+':'+tostr(Min)+':'+tostr(Sec) Else Result:=tostr(Hour)+'.'+tostr(Min)+'.'+tostr(Sec); End; ftDateTime: Begin dt:=field.GetAsDateTime; DecodeDate(dt,Year,Month,Day); RoundDecodeTime(dt,Hour,Min,Sec); If Field.FDataSet.FDBProcs.DBType=Native_Oracle7 Then Begin s:=tostr(Year); While length(s)<4 Do s:='0'+s; s1:=tostr(Month); If length(s1)<2 Then s1:='0'+s1; s2:=tostr(Day); If length(s2)<2 Then s2:='0'+s2; Result:='TO_DATE('#39+s+'-'+s1+'-'+s2; s:=tostr(Hour); If length(s)<2 Then s:='0'+s; s1:=tostr(Min); If length(s1)<2 Then s1:='0'+s1; s2:=tostr(Sec); If length(s2)<2 Then s2:='0'+s2; Result:=Result+' '+s+'.'+s1+'.'+s2; Result:=Result+#39','#39'YYYY-MM-DD HH24.MI.SS'#39')'; exit; End Else Begin Result:=tostr(Year)+'-'+tostr(Month)+'-'+tostr(Day); Result:=Result+'-'+tostr(Hour)+'.'+tostr(Min)+'.'; Result:=Result+tostr(Sec)+'.00'; End; End; ftMemo: Begin Result:=PChar(Field.FValue)^; End; ftFloat: Begin Result:=field.AsString; //eliminate decimal separator If pos(',',Result)<>0 Then Result[pos(',',Result)]:='.'; End; Else Result:=field.AsString; End; {Case} If Not (field.DataType In [ftSmallInt,ftInteger,ftWord,ftFloat,ftCurrency]) Then Result:=#39+Result+#39; End; Procedure TDataSet.CommitInsert(Commit:Boolean); Begin End; Procedure TDataSet.RemoveCurrentFields; Var Col,Row:LongInt; Field:TField; FieldDef:TFieldDef; Begin FieldDef := Nil; For Col := 0 To FFieldDefs.Count-1 Do Begin FieldDef := FFieldDefs[Col]; Field := FieldDef.Fields[FCurrentRow]; If Field <> Nil Then Begin FieldDef.Fields.Remove(Field); Field.Destroy; End; For Row := FCurrentRow To FieldDef.Fields.Count-1 Do Begin Field := FieldDef.Fields[Row]; If Field <> Nil Then Dec(Field.FRow); End; End; If FieldDef <> Nil Then If FCurrentRow >= FieldDef.Fields.Count Then FCurrentRow := FieldDef.Fields.Count-1; End; Function TDataSet.UpdateFieldSelect(Field:TField):Boolean; Begin Result:=False; End; Procedure TDataSet.UpdateField(field:TField;OldValue:Pointer;OldValueLen:LongInt); Begin If Not FOpened Then Exit; If FSelect.Count=0 Then Exit; //Nothing To Select Try If Not UpdateFieldSelect(field) Then Begin FreeMem(field.FValue,field.FValueLen); field.FValue:=OldValue; field.FValueLen:=OldValueLen; End Else FreeMem(OldValue,OldValueLen); Except FreeMem(field.FValue,field.FValueLen); field.FValue:=OldValue; field.FValueLen:=OldValueLen; Raise; End; End; Procedure TDataSet.Post; Begin If Not FOpened Then Exit; If (CurrentRow < 0) Or (CurrentRow >= RecordCount) Then exit; Try CheckRequiredFields; If FBeforePost <> Nil Then FBeforePost(Self); If FRowIsInserted Then CommitInsert(True) Else DoPost; DataChange(deDataBaseChanged); If FAfterPost <> Nil Then FAfterPost(Self); Except Raise; End; End; Procedure TDataSet.DoPost; Begin End; Procedure TDataSet.Cancel; Begin If Not FOpened Then Exit; If (CurrentRow < 0) Or (CurrentRow >= RecordCount) Then exit; Try If FBeforeCancel <> Nil Then FBeforeCancel(Self); If FRowIsInserted Then CommitInsert(False) Else DoCancel; DataChange(deDataBaseChanged); If FAfterCancel <> Nil Then FAfterCancel(Self); Except Raise; End; End; Procedure TDataSet.DoCancel; Begin End; Procedure TDataSet.QueryTable; Begin End; Procedure TDataSet.Loaded; Begin Inherited Loaded; If FRefreshOnLoad Then Active:=True; End; Procedure TDataSet.CheckInactive; Begin If Active Then Begin //Close; DatabaseError('Cannot perform this operation on active dataset !'); End; End; Function TDataSet.IsTable:Boolean; Begin Result := (Self Is TTable) And (Not (Self Is TQuery)) And (Not (Self Is TStoredProc)); End; { ษอออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออป บ บ บ Speed-Pascal/2 Version 2.0 บ บ บ บ Speed-Pascal Component Classes (SPCC) บ บ บ บ This section: TTable Class Implementation บ บ บ บ (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! บ บ บ ศอออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออผ } Procedure TTable.GetPrimaryKeys(List:TStrings); Begin GetKeys(List,True); End; Function MapODBCType(colType:TFieldType):SQLSMALLINT; Begin Case colType Of ftString:Result:=SQL_VARCHAR; ftCurrency:Result:=SQL_NUMERIC; ftInteger:Result:=SQL_INTEGER; ftSmallInt:Result:=SQL_SMALLINT; ftFloat:Result:=SQL_DOUBLE; ftDate:Result:=SQL_DATE; ftTime:Result:=SQL_TIME; ftDateTime:Result:=SQL_TIMESTAMP; ftMemo:Result:=SQL_LONGVARCHAR; ftBlob:Result:=SQL_VARBINARY; ftGraphic:Result:=SQL_VARGRAPHIC; Else Result:=SQL_BLOB; End; {Case} End; Function TTable.DataType2Name(DataType:TFieldType):String; Var List:TStringList; t:LongInt; Begin Result:=''; Case FDBProcs.DBType Of Native_Oracle7: Begin Case DataType Of ftString:Result:='VARCHAR2'; ftSmallInt,ftInteger,ftWord:Result:='INT'; ftBoolean:Result:='CHAR'; ftFloat,ftCurrency:Result:='FLOAT'; ftDate,ftTime,ftDateTime:Result:='DATE'; ftBytes,ftBlob,ftMemo,ftGraphic,ftFmtMemo, ftTypedBinary:Result:='RAW'; ftVarBytes:Result:='LONG RAW'; End; End; Native_msql: Begin Case DataType Of ftString:Result:='CHAR'; ftSmallInt,ftInteger,ftWord:Result:='INT'; ftBoolean:Result:='CHAR'; ftFloat,ftCurrency:Result:='REAL'; ftDate:Result:='DATE'; ftTime:Result:='TIME'; ftMemo,ftFmtMemo:Result:='TEXT'; End; End; Native_DBase: Begin Case DataType Of ftString: Result := 'CHAR'; ftDate: Result := 'DATE'; ftFloat,ftCurrency: Result := 'FLOAT'; ftSmallInt,ftInteger,ftWord: Result := 'INT'; ftBoolean: Result := 'BOOL'; ftMemo: Result := 'TEXT'; ftBlob: Result := 'BLOB'; Else Result := ''; End; End; Native_Paradox: Begin Case DataType Of ftString: Result := 'CHAR'; ftDate: Result := 'DATE'; ftSmallInt: Result := 'SINT'; ftInteger: Result := 'INT'; ftFloat: Result := 'FLOAT'; ftCurrency: Result := 'MONEY'; //ftInteger: Result := 'NUMBER'; ftBoolean: Result := 'BOOL'; ftMemo: Result := 'TEXT'; ftBlob: Result := 'BLOB'; ftFmtMemo: Result := 'FMTTEXT'; ftTime: Result := 'TIME'; ftDateTime: Result := 'DATETIME'; ftAutoInc: Result := 'AUTOINC'; ftBCD: Result := 'BCD'; ftBytes: Result := 'BYTES'; Else Result := ''; End; End; Else Begin If FDataTypes=Nil Then Begin List.Create; GetDataTypes(List); List.Destroy; End; Result:=''; If FDataTypes=Nil Then exit; For t:=0 To FDataTypes.Count-1 Do If TFieldType(FDataTypes.Objects[t])=DataType Then Begin Result:=FDataTypes[t]; exit; End; End; End; //case End; Function TTable.GetIndexDefs:TIndexDefs; Begin If ((FIndexDefs=Nil)Or(FIndexDefs.Count=0)) Then UpdateIndexDefs; Result:=FIndexDefs; End; Procedure UpdateIndexFieldMap(Table:TTable); Var t,Index:LongInt; IndexDef:TIndexDef; s,s1:String; Begin If Table.FIndexFieldMap<>Nil Then Table.FIndexFieldMap.Clear Else Table.FIndexFieldMap.Create; For t:=0 To Table.IndexDefs.Count-1 Do Begin IndexDef:=Table.IndexDefs[t]; s:=IndexDef.Fields; While pos(';',s)<>0 Do Begin s1:=Copy(s,1,pos(';',s)-1); System.Delete(s,1,pos(';',s)); Index:=Table.FieldDefs.IndexOf(s1); If Index>=0 Then If Table.FIndexFieldMap.IndexOf(Pointer(Index))<0 Then Table.FIndexFieldMap.Add(Pointer(Index)); End; If s<>'' Then Begin Index:=Table.FieldDefs.IndexOf(s); If Index>=0 Then If Table.FIndexFieldMap.IndexOf(Pointer(Index))<0 Then Table.FIndexFieldMap.Add(Pointer(Index)); End; End; End; Function TTable.GetIndexFieldCount:LongInt; Begin If ((FIndexFieldMap=Nil)Or(FIndexFieldMap.Count=0)) Then UpdateIndexFieldMap(Self); Result:=FIndexFieldMap.Count End; Function TTable.GetIndexField(Index:LongInt):TField; Begin If ((FIndexFieldMap=Nil)Or(FIndexFieldMap.Count=0)) Then UpdateIndexFieldMap(Self); Result:=Fields[LongInt(FIndexFieldMap[Index])] End; Procedure TTable.SetIndexField(Index:LongInt;NewValue:TField); Begin GetIndexField(Index).Assign(NewValue); End; Procedure TTable.AddIndex(Const Name:String;Fields:String;Options:TIndexOptions); Var OldActive,OldOpen:Boolean; S1,s2:String; ahstmt:SQLHSTMT; Begin If (Not IsTable) Then SQLError('Illegal operation'); OldActive:=FActive; OldOpen:=FOpened; If Not FOpened Then Begin FActive:=True; DoOpen; If Not FOpened Then Active:=False; End; s1:='CREATE'; If Options*[ixUnique]<>[] Then s1:=s1+' UNIQUE'; s1:=s1+' INDEX '+Name+' ON '+TableName+'('; While pos(';',Fields)<>0 Do Begin s2:=Copy(Fields,1,pos(';',Fields)-1); System.Delete(Fields,1,pos(';',Fields)); If s1[length(s1)]<>'(' Then s1:=s1+','; s1:=s1+s2; If FDBProcs.DBType<>Native_Msql Then Begin If Options*[ixDescending]<>[] Then s1:=s1+' DESC' Else s1:=s1+' ASC'; End; End; If s1[length(s1)]<>'(' Then s1:=s1+','; s1:=s1+Fields; If FDBProcs.DBType<>Native_Msql Then Begin If Options*[ixDescending]<>[] Then s1:=s1+' DESC' Else s1:=s1+' ASC'; End; s1:=s1+')'; If FOpened Then Begin EnterSQLProcessing; FDBProcs.SQLAllocStmt(FDBProcs.ahdbc,ahstmt); If FDBProcs.SQLExecDirect(ahstmt,s1,SQL_NTS)<>SQL_SUCCESS Then Begin S1:=SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,ahstmt); FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP); SQLError(LoadNLSStr(SErrorExecutingSQLStatement)+': '+S1); End; FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP); LeaveSQLProcessing; End; DoPost; If not OldOpen Then DoClose; FActive:=OldActive; UpdateIndexDefs; End; Procedure TTable.DeleteIndex(Const Name: string); Var OldActive,OldOpen:Boolean; S1:String; ahstmt:SQLHSTMT; Begin If (Not IsTable) Then SQLError('Illegal operation'); OldActive:=FActive; OldOpen:=FOpened; If Not FOpened Then Begin FActive:=True; DoOpen; If Not FOpened Then Active:=False; End; If FOpened Then Begin EnterSQLProcessing; FDBProcs.SQLAllocStmt(FDBProcs.ahdbc,ahstmt); s1:='DROP INDEX '+Name; If FDBProcs.DBType=Native_msql Then s1:=s1+' FROM '+TableName; If FDBProcs.SQLExecDirect(ahstmt,s1,SQL_NTS)<>SQL_SUCCESS Then Begin S1:=SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,ahstmt); FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP); SQLError(LoadNLSStr(SErrorExecutingSQLStatement)+': '+S1); End; FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP); LeaveSQLProcessing; End; DoPost; If not OldOpen Then DoClose; FActive:=OldActive; UpdateIndexDefs; End; Procedure TTable.CreateTable; Var s:AnsiString; s1:String; ahstmt:SQLHSTMT; t:LongInt; FieldDef:TFieldDef; OldActive:Boolean; Begin If (Not IsTable) Then SQLError('Illegal operation'); CheckInactive; s:='CREATE TABLE '+TableName+'('; For t:=0 To FieldDefs.Count-1 Do Begin FieldDef:=FieldDefs[t]; s1:=FieldDef.TypeName; s:=s+FieldDef.Name+' '+s1; If ((FieldDef.DataType=ftString)Or(s1='LONG RAW')) Then s:=s+'('+tostr(FieldDef.Size)+')'; If FieldDef.Required then s:=s+' NOT NULL'; If FieldDef.PrimaryKey Then s:=s+' PRIMARY KEY'; If FieldDef.ForeignKey<>'' Then s:=s+' REFERENCES '+FieldDef.ForeignKey; If t<>FieldDefs.Count-1 Then s:=s+','; End; s:=s+')'; OldActive:=FActive; If Not FOpened Then Begin FActive:=True; DoOpen; If Not FOpened Then Active:=False; End; If FOpened Then Begin EnterSQLProcessing; FDBProcs.SQLAllocStmt(FDBProcs.ahdbc,ahstmt); If FDBProcs.SQLExecDirect(ahstmt,PChar(s)^,SQL_NTS)<>SQL_SUCCESS Then Begin S1:=SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,ahstmt); FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP); SQLError(LoadNLSStr(SErrorExecutingSQLStatement)+': '+S1); End; FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP); LeaveSQLProcessing; End; DoClose; FActive:=OldActive; End; Procedure TTable.DeleteTable; Var s1:String; ahstmt:SQLHSTMT; Begin If (Not IsTable) Then SQLError('Illegal operation'); If Active Then DoClose; If Not FOpened Then Begin FActive:=True; DoOpen; If Not FOpened Then Active:=False; End; If FOpened Then Begin EnterSQLProcessing; FDBProcs.SQLAllocStmt(FDBProcs.ahdbc,ahstmt); If FDBProcs.SQLExecDirect(ahstmt,'DROP TABLE '+TableName,SQL_NTS)<>SQL_SUCCESS Then Begin S1:=SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,ahstmt); FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP); SQLError(LoadNLSStr(SErrorExecutingSQLStatement)+': '+S1); End; FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP); LeaveSQLProcessing; End; DoPost; DoClose; End; Procedure TTable.EmptyTable; Var OldActive,OldOpen:Boolean; S1:String; ahstmt:SQLHSTMT; Begin If (Not IsTable) Then SQLError('Illegal operation'); OldActive:=FActive; OldOpen:=FOpened; If Not FOpened Then Begin FActive:=True; DoOpen; If Not FOpened Then Active:=False; End; If FOpened Then Begin EnterSQLProcessing; FDBProcs.SQLAllocStmt(FDBProcs.ahdbc,ahstmt); If FDBProcs.SQLExecDirect(ahstmt,'DELETE * FROM '+TableName,SQL_NTS)<>SQL_SUCCESS Then Begin S1:=SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,ahstmt); FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP); SQLError(LoadNLSStr(SErrorExecutingSQLStatement)+': '+S1); End; FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP); LeaveSQLProcessing; End; DoPost; If not OldOpen Then DoClose; FActive:=OldActive; End; Function TTable.FindKey(Const KeyValues:Array of Const):Boolean; Begin If (Not IsTable) Then SQLError('Illegal operation'); Result:=False; //??? End; Procedure TTable.GetIndexNames(List: TStrings); Var t:LongInt; Begin List.Clear; For t:=0 To IndexDefs.Count-1 Do List.Add(IndexDefs[t].Name); End; Procedure TTable.RenameTable(NewTableName:String); Var OldActive,OldOpen:Boolean; S1:String; ahstmt:SQLHSTMT; tn:String; Begin If (Not IsTable) Then SQLError('Illegal operation'); OldActive:=FActive; OldOpen:=FOpened; If Not FOpened Then Begin FActive:=True; DoOpen; If Not FOpened Then Active:=False; End; If FOpened Then Begin EnterSQLProcessing; FDBProcs.SQLAllocStmt(FDBProcs.ahdbc,ahstmt); tn:=TableName; If FDBProcs.DBType=Native_Oracle7 Then //no qualifiers ! Begin If pos('.',NewTableName)<>0 Then System.Delete(NewTableName,1,pos('.',NewTableName)); If pos('.',tn)<>0 Then System.Delete(tn,1,pos('.',tn)); End; If FDBProcs.DBType=Native_Oracle7 Then s1:='RENAME '+tn+' TO '+NewTableName Else s1:='ALTER TABLE '+TableName+' RENAME '+NewTableName; If FDBProcs.SQLExecDirect(ahstmt,s1,SQL_NTS)<>SQL_SUCCESS Then Begin S1:=SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,ahstmt); FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP); SQLError(LoadNLSStr(SErrorExecutingSQLStatement)+': '+S1); End; FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP); LeaveSQLProcessing; End; DoPost; DoClose; TableName:=NewTableName; FActive:=OldActive; End; Procedure TTable.GetNames(List:TStrings;Const Name:String); Var ahstmt:SQLHSTMT; cols:SQLSMALLINT; I:LongInt; C:Array[0..4] Of cstring; OutLen:Array[0..4] Of SQLINTEGER; rc:SQLRETURN; S,S1:String; OldActive:Boolean; OldOpen:Boolean; Index:LongInt; Begin List.Clear; If ((ComponentState*[csReading]=[])And(Not FDataSetLocked)) Then Begin OldActive:=FActive; OldOpen:=FOpened; If Not FOpened Then Begin FActive:=True; DoOpen; If Not FOpened Then Active:=False; End; If FOpened Then Begin EnterSQLProcessing; FDBProcs.SQLAllocStmt(FDBProcs.ahdbc,ahstmt); If FDBProcs.SQLTables(ahstmt,Nil,0,Nil,0,Nil,0,Name,SQL_NTS)=SQL_SUCCESS Then Begin FDBProcs.SQLNumResultCols(ahstmt,cols); If cols>5 Then cols:=5; For I := 0 To cols-1 Do FDBProcs.SQLBindCol(ahstmt, I + 1, SQL_C_CHAR, C[I], 255, OutLen[I]); rc:=FDBProcs.SQLFetch(ahstmt); While ((rc<>SQL_NO_DATA_FOUND)And(rc<>SQL_ERROR)) Do Begin If Cols=1 Then Index:=0 //msql Else Index:=2; If OutLen[Index]<>SQL_NULL_DATA Then Begin Move(C[Index],S[1],OutLen[Index]); S[0]:=Chr(OutLen[Index]); If S[length(s)]=#0 Then If length(S)>0 Then dec(S[0]); If Cols>1 Then //get qualifier If OutLen[0]<>SQL_NULL_DATA Then Begin Move(C[0],S1[1],OutLen[0]); S1[0]:=Chr(OutLen[0]); If S1[length(S1)]=#0 Then If length(S1)>0 Then dec(S1[0]); If S1<>'' Then S:=S1+'.'+S; End; List.Add(S); End; rc:=FDBProcs.SQLFetch(ahstmt); End; End; FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP); LeaveSQLProcessing; End; If Not OldOpen Then DoClose; FActive:=OldActive; End; End; Procedure TTable.GetViewNames(List:TStrings); Begin GetNames(List,'VIEW'); End; Procedure TTable.GetSystemTableNames(List:TStrings); Begin GetNames(List,'SYSTEM TABLE'); End; Procedure TTable.GetSynonymNames(List:TStrings); Begin GetNames(List,'SYNONYM'); End; Function MapSQLType(colType:SQLSMALLINT):TFieldType; Begin Case colType Of SQL_CHAR:Result:=ftString; SQL_NUMERIC:Result:=ftFloat; SQL_DECIMAL:Result:=ftFloat; SQL_INTEGER:Result:=ftInteger; SQL_SMALLINT:Result:=ftSmallInt; SQL_FLOAT:Result:=ftFloat; SQL_REAL:Result:=ftFloat; SQL_DOUBLE:Result:=ftFloat; SQL_DATE:Result:=ftDate; SQL_TIME:Result:=ftTime; SQL_TIMESTAMP:Result:=ftDateTime; SQL_VARCHAR:Result:=ftString; SQL_LONGVARCHAR:Result:=ftMemo; SQL_BINARY:Result:=ftBlob; SQL_VARBINARY:Result:=ftBlob; SQL_LONGVARBINARY:Result:=ftBlob; {SQL_BIGINT =-5; /* Not supported */ SQL_TINYINT =-6; /* Not supported */} SQL_BIT:Result:=ftBoolean; SQL_GRAPHIC:Result:=ftGraphic; SQL_VARGRAPHIC:Result:=ftGraphic; SQL_LONGVARGRAPHIC:Result:=ftGraphic; SQL_BLOB:Result:=ftBlob; SQL_CLOB:Result:=ftBlob; SQL_DBCLOB:Result:=ftBlob; Else Result:=ftUnknown; End; {Case} End; Procedure TTable.GetDataTypes(List:TStrings); Var OldActive:Boolean; OldOpen:Boolean; Index:LongInt; Procedure GetType(Typ:SQLSMALLINT); Var cols:SQLSMALLINT; I:LongInt; C:cstring; OutLen:SQLINTEGER; rc:SQLRETURN; S,S1:String; ahstmt:SQLHSTMT; Begin EnterSQLProcessing; FDBProcs.SQLAllocStmt(FDBProcs.ahdbc,ahstmt); If FDBProcs.SQLGetTypeInfo(ahstmt,Typ)=SQL_SUCCESS Then Begin FDBProcs.SQLNumResultCols(ahstmt,cols); If cols=0 Then exit; FDBProcs.SQLBindCol(ahstmt, 1, SQL_C_CHAR, C, 255, OutLen); rc:=FDBProcs.SQLFetch(ahstmt); If ((rc<>SQL_NO_DATA_FOUND)And(rc<>SQL_ERROR)) Then Begin If OutLen<>SQL_NULL_DATA Then Begin Move(C,S[1],OutLen); S[0]:=Chr(OutLen); If S[length(s)]=#0 Then If length(s)>0 Then dec(S[0]); UpcaseStr(S); If List.IndexOf(S)<0 Then List.AddObject(S,Pointer(MapSQLType(Typ))); End; End; End; FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP); LeaveSQLProcessing; End; Procedure ListAddObject(Const s:String;DataType:TFieldType); Begin List.AddObject(s,Pointer(DataType)); End; Begin List.Clear; Case FDBProcs.DBType Of Native_Oracle7: Begin ListAddObject('CHAR',ftString); ListAddObject('VARCHAR2',ftString); ListAddObject('FLOAT',ftFloat); ListAddObject('INT',ftInteger); ListAddObject('DATE',ftDateTime); ListAddObject('RAW',ftBlob); ListAddObject('LONG RAW',ftBlob); End; Native_msql: Begin ListAddObject('CHAR',ftString); ListAddObject('INT',ftInteger); ListAddObject('UINT',ftInteger); ListAddObject('REAL',ftFloat); ListAddObject('TEXT',ftMemo); ListAddObject('DATE',ftDate); ListAddObject('TIME',ftTime); ListAddObject('MONEY',ftInteger); End; Native_DBase: Begin ListAddObject('CHAR',ftString); ListAddObject('INT',ftInteger); ListAddObject('FLOAT',ftFloat); ListAddObject('TEXT',ftMemo); ListAddObject('DATE',ftDate); ListAddObject('BOOL',ftBoolean); ListAddObject('BLOB',ftBlob); End; Native_Paradox: Begin ListAddObject('CHAR',ftString); ListAddObject('DATE',ftDate); ListAddObject('SINT',ftSmallInt); ListAddObject('INT',ftInteger); ListAddObject('FLOAT',ftFloat); ListAddObject('MONEY',ftCurrency); ListAddObject('NUMBER',ftInteger); ListAddObject('BOOL',ftBoolean); ListAddObject('TEXT',ftMemo); ListAddObject('BLOB',ftBlob); ListAddObject('FMTTEXT',ftFmtMemo); ListAddObject('TIME',ftTime); ListAddObject('DATETIME',ftDateTime); ListAddObject('AUTOINC',ftAutoInc); ListAddObject('BCD',ftBCD); ListAddObject('BYTES',ftBytes); End; Else Begin If FDataTypes<>Nil Then Begin List.Assign(FDataTypes); exit; End; If @FDBProcs.SQLGetTypeInfo=Nil Then exit; If ((ComponentState*[csReading]=[])And(Not FDataSetLocked)) Then Begin OldActive:=FActive; OldOpen:=FOpened; If Not FOpened Then Begin FActive:=True; DoOpen; If Not FOpened Then Active:=False; End; If FOpened Then Begin GetType(SQL_BIGINT); GetType(SQL_BINARY); GetType(SQL_BIT); GetType(SQL_CHAR); GetType(SQL_DATE); GetType(SQL_DECIMAL); GetType(SQL_DOUBLE); GetType(SQL_FLOAT); GetType(SQL_INTEGER); GetType(SQL_LONGVARBINARY); GetType(SQL_LONGVARCHAR); GetType(SQL_NUMERIC); GetType(SQL_REAL); GetType(SQL_SMALLINT); GetType(SQL_TIME); GetType(SQL_TIMESTAMP); GetType(SQL_TINYINT); GetType(SQL_VARBINARY); GetType(SQL_VARCHAR); End; If Not OldOpen Then DoClose; FActive:=OldActive; If FDataTypes=Nil Then If List.Count>0 Then Begin FDataTypes.Create; FDataTypes.Assign(List); End; End; End; End; End; Procedure TTable.GetForeignKeys(List:TStrings); Begin GetKeys(List,False); End; Procedure TTable.GetTableNames(List:TStrings); Begin GetNames(List,'TABLE'); End; Procedure TTable.SetTableLock(LockType:TLockType;Lock:Boolean); Var C:cstring; ahstmt:SQLHSTMT; S:String; Begin If Lock Then Begin C:='LOCK TABLE '+TableName+' IN '; If LockType=ltReadLock Then C:=C+'EXCLUSIVE' Else C:=C+'SHARE'; C:=C+' MODE'; End Else C:='ROLLBACK'; EnterSQLProcessing; FDBProcs.SQLAllocStmt(FDBProcs.ahdbc,ahstmt); If FDBProcs.SQLExecDirect(ahstmt,C,SQL_NTS)<>SQL_SUCCESS Then Begin S:=SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,ahstmt); FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP); SQLError(LoadNLSStr(SErrorExecutingSQLStatement)+': '+S); End; FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP); LeaveSQLProcessing; End; Procedure TTable.LockTable(LockType:TLockType); Begin SetTableLock(LockType,True); End; Procedure TTable.UnlockTable(LockType:TLockType); Begin SetTableLock(LockType,False); End; Procedure TTable.ReadSCUResource(Const ResName:TResourceName;Var Data;DataLen:LongInt); Var S:String; Begin If ResName = rnDBTable Then Begin Move(Data,S,DataLen); TableName:=S; End Else Inherited ReadSCUResource(ResName,Data,DataLen); End; Function TTable.WriteSCUResource(Stream:TResourceStream):Boolean; Var S:String; Begin Result := False; If Inherited WriteSCUResource(Stream) Then Begin S:=TableName; Result:=Stream.NewResourceEntry(rnDBTable,S,Length(S)+1); End; End; Function TTable.GetTableName:String; Begin Result:=FTableName^; End; Procedure TTable.SetupComponent; Begin AssignStr(FTableName,''); AssignStr(FMasterFields,''); Inherited SetupComponent; Name:='Table'; End; Procedure TTable.SetActive(NewValue:Boolean); Begin If FActive = NewValue Then exit; Inherited SetActive(NewValue); If FActive Then Begin RefreshTable; FActive := FOpened; End Else DoClose; End; Procedure TTable.RefreshTable; Begin If ((csReading In ComponentState) Or (FDataSetLocked)) Then Begin FRefreshOnLoad := FActive; Exit; End; DoOpen; If Not FOpened Then Exit; If TableName <> '' Then QueryTable; End; Procedure TTable.SetTableName(NewValue:String); Begin If GetTableName=NewValue Then Exit; If FIndexDefs<>Nil Then FIndexDefs.Clear; AssignStr(FTableName,NewValue); FSelect.Clear; NewValue:='SELECT * FROM '+ NewValue; FSelect.Add(NewValue); If FActive Then Begin RefreshTable; DataChange(deTableNameChanged); End; End; Function TTable.GetPassword:String; Begin Result:=FDBProcs.pwd; End; Function TTable.GetUserId:String; Begin Result:=FDBProcs.uid; End; Procedure TTable.SetPassword(NewValue:String); Begin If FOpened Then Begin ErrorBox(LoadNLSStr(SCannotPerformDBAction)); Exit; End; FDBProcs.pwd:=NewValue; End; Procedure TTable.SetUserId(NewValue:String); Begin If FOpened Then Begin ErrorBox(LoadNLSStr(SCannotPerformDBAction)); Exit; End; FDBProcs.uid:=NewValue; End; Destructor TTable.Destroy; Begin DoClose; FreeDBProcs(FDBProcs); AssignStr(FTableName,''); If FServants<>Nil Then Begin NotifyServants(Self); FServants.Destroy; End; FServants:=Nil; If FDataTypes<>Nil Then Begin FDataTypes.Destroy; FDataTypes:=Nil; End; If FIndexDefs<>Nil Then Begin FIndexDefs.Destroy; FIndexDefs:=Nil; End; If FIndexFieldMap<>Nil Then Begin FIndexFieldMap.Destroy; FIndexFieldMap:=Nil; End; If FMasterSource<>Nil Then If FMasterSource.DataSet Is TTable Then TTable(FMasterSource.DataSet).ConnectServant(Self,False); AssignStr(FMasterFields,''); Inherited Destroy; End; Procedure TTable.Loaded; Begin If FTempMasterSource<>Nil Then If FTempMasterSource.DataSet Is TTable Then If FMasterSource=Nil Then MasterSource:=FTempMasterSource; Inherited Loaded; End; {$HINTS OFF} Procedure TTable.UpdateLinkList(Const PropertyName:String;LinkList:TList); Var T:LongInt; DataSource:TDataSource; Begin For T:=LinkList.Count-1 DownTo 0 Do Begin DataSource:=TDataSource(LinkList[T]); If DataSource Is TDataSource Then Begin If DataSource.DataSet Is TTable Then Begin //no recursive elements !! If TTable(DataSource.DataSet)=Self Then LinkList.Remove(DataSource); End Else Begin //no DataSources that are Not linked To tables ! LinkList.Remove(DataSource); End; End; End; End; {$HINTS ON} Procedure TTable.SetMasterSource(NewValue:TDataSource); Var OldLocked:Boolean; IsLoaded:Boolean; Begin If NewValue=FMasterSource Then Exit; If NewValue<>Nil Then Begin If Not (NewValue.DataSet Is TTable) Then Begin IsLoaded:=((ComponentState*[csReading]=[])And(Not FDataSetLocked)); If ((NewValue.DataSet=Nil)And(Not IsLoaded)) Then FTempMasterSource:=NewValue Else If ComponentState*[csDesigning]<>[] Then ErrorBox(LoadNLSStr(SDataSourceLinkError)); Exit; End; If TTable(NewValue.DataSet)=Self Then Begin If ComponentState*[csDesigning]<>[] Then ErrorBox('Illegal recursive DataSource link'); Exit; End; If ((FServants<>Nil)And(FServants.IndexOf(NewValue.DataSet)>=0)) Then Begin If ComponentState*[csDesigning]<>[] Then ErrorBox('Illegal circular DataSource link'); Exit; End; End; //prevent call Of RefreshTable In ConnectServant OldLocked:=FDataSetLocked; FDataSetLocked:=True; If FMasterSource<>Nil Then If FMasterSource.DataSet Is TTable Then TTable(FMasterSource.DataSet).ConnectServant(Self,False); FMasterSource:=NewValue; FDataSetLocked:=OldLocked; If FMasterSource<>Nil Then Begin If FMasterSource.DataSet Is TTable Then TTable(FMasterSource.DataSet).ConnectServant(Self,True) Else If ((ComponentState*[csReading]=[])And(Not FDataSetLocked)) Then RefreshTable; End Else If ((ComponentState*[csReading]=[])And(Not FDataSetLocked)) Then RefreshTable; End; Function TTable.GetMasterFields:String; Begin Result:=FMasterFields^; End; Procedure TTable.SetMasterFields(Const NewValue:String); Begin If GetMasterFields=NewValue Then exit; AssignStr(FMasterFields,NewValue); If ((ComponentState*[csReading]=[])And(Not FDataSetLocked)) Then RefreshTable; End; Procedure TTable.ConnectServant(Servant:TTable;Connect:Boolean); Begin If Connect Then Begin If FServants=Nil Then FServants.Create; FServants.Add(Servant); End Else If FServants<>Nil Then Begin If FServants.IndexOf(Servant)>=0 Then FServants.Remove(Servant); End; If ((Servant.ComponentState*[csReading]=[])And(Not Servant.FDataSetLocked)) Then Servant.RefreshTable; End; Procedure TTable.DataChange(event:TDataChange); Var T:LongInt; Servant:TTable; Begin If FServants<>Nil Then For T:=0 To FServants.Count-1 Do Begin Servant:=FServants[T]; If ((Servant.ComponentState*[csReading]=[])And(Not Servant.FDataSetLocked)) Then Servant.RefreshTable; End; Inherited DataChange(event); End; Function TTable.GetResultColRow(Col,Row:LongInt):TField; Var FieldDef:TFieldDef; I,t:LongInt; field:TField; rc:SQLRETURN; OutLen:LongInt; Temp:Pointer; NewLen:LongInt; MapType:LongInt; S:String; ActRows:LongWord; RowStatus:Word; ExtFetchOk:Boolean; e:Extended; Header:TGraphicHeader; Label again,err; Begin Result := Nil; If Not FOpened Then Exit; Result := Inherited GetResultColRow(Col,Row); If Result <> Nil Then exit; If FDBProcs.ahstmt=0 Then Exit; {no previous Select Command Or no more Rows} /* Store Result Row(S) */ again: //Try if we are able to retrieve cursored rows ! If Self Is TStoredProc Then //due to "Function sequence error" Begin rc:=FDBProcs.SQLFetch(FDBProcs.ahstmt); ExtFetchOk:=False; End Else Begin rc:=FDBProcs.SQLExtendedFetch(FDBProcs.ahstmt,SQL_FETCH_ABSOLUTE, Row+1,ActRows,RowStatus); ExtFetchOk:=rc<>SQL_ERROR; If not ExtFetchOk Then rc:=FDBProcs.SQLFetch(FDBProcs.ahstmt); //Driver not capable (DB2 !) End; FieldDef:=FFieldDefs[0]; If ((rc<>SQL_NO_DATA_FOUND)And(rc<>SQL_ERROR)) Then Begin For I:=0 To FFieldDefs.Count-1 Do Begin FieldDef:=FFieldDefs[I]; {Create Row} Field := FieldDef.CreateField(Nil); If ExtFetchOk Then Field.FRow:=Row+1 Else Field.FRow:=FieldDef.Fields.Count; Field.FCol:=I; Case FieldDef.DataType Of ftBytes,ftVarBytes,ftBlob,ftMemo,ftGraphic, ftFmtMemo,ftTypedBinary:MapType:=SQL_C_BINARY; ftFloat: Begin Case FieldDef.Size Of 4:MapType:=SQL_C_FLOAT; Else MapType:=SQL_C_DOUBLE; End; //case End; Else MapType:=SQL_C_DEFAULT; End; rc:=FDBProcs.SQLGetData(FDBProcs.ahstmt,I+1,MapType,field.FValue^, FieldDef.Size,OutLen); If rc<>SQL_ERROR Then Begin If ((rc=SQL_SUCCESS_WITH_INFO)And(OutLen>field.FValueLen)And (MapType=SQL_C_BINARY)) Then Begin NewLen:=OutLen-field.FValueLen; GetMem(Temp,OutLen); Move(Field.FValue^,Temp^,Field.FValueLen); FreeMem(Field.FValue,Field.FValueLen); Field.FValue:=Temp; Inc(Temp,field.FValueLen); Field.FValueLen:=OutLen; rc:=FDBProcs.SQLGetData(FDBProcs.ahstmt,I+1,MapType,Temp^, NewLen,OutLen); If rc=SQL_ERROR Then Begin Field.Destroy; Goto err; End; OutLen:=Field.FValueLen+1; End; If OutLen=SQL_NULL_DATA Then Begin Field.FreeMemory; //TOM TEST End Else Begin If OutLen<=field.FValueLen Then Begin GetMem(Temp,OutLen); Move(Field.FValue^,Temp^,OutLen); FreeMem(Field.FValue,Field.FValueLen); Field.FValue:=Temp; Field.FValueLen:=OutLen; End; End; If ExtFetchOk Then Begin If Row<=FieldDef.Fields.Count-1 Then Begin FieldDef.Fields[Row]:=Field; End Else Begin For t:=FieldDef.Fields.Count+1 To Row Do FieldDef.Fields.Add(Nil); FieldDef.Fields.Add(Field); End; End Else FieldDef.Fields.Add(Field); End Else Begin Field.Destroy; Goto err; End; If Field Is TBlobField Then // check graphic header Begin If Field.FValueLen >= SizeOf(TGraphicHeader) Then Begin move(Field.FValue^, Header, SizeOf(TGraphicHeader)); If (Header.Count = 1) And (Header.HType = $0100) And (Header.Size = Field.FValueLen - SizeOf(TGraphicHeader)) Then Begin GetMem(Temp, Header.Size); inc(Field.FValue, SizeOf(TGraphicHeader)); Move(Field.FValue^,Temp^, Header.Size); dec(Field.FValue, SizeOf(TGraphicHeader)); FreeMem(Field.FValue, Field.FValueLen); Field.FValue := Temp; Field.FValueLen := Header.Size; //Field.FBlobType := ftGraphic; End; End; End; End; FieldDef:=FFieldDefs[Col]; If ((ExtFetchOk)Or(Row=FieldDef.Fields.Count-1)) Then Begin {result found} Result:=FieldDef.Fields.Items[Row]; exit; End; Goto again; {fetch Next Row} End Else Begin {no more Rows} If rc=SQL_ERROR Then Begin err: S:=SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,FDBProcs.ahstmt); CloseStmt; SQLError('Error fetching result row '+FieldDef.Name+#13#10+S); End; CloseStmt; End; End; Procedure TTable.GetKeys(List:TStrings;Primary:Boolean); Var ahstmt:SQLHSTMT; cols:SQLSMALLINT; C:Array[0..8] Of cstring; cc:cstring; S,S1:String; I:LongInt; OutLen:Array[0..8] Of SQLINTEGER; rc:SQLRETURN; Offset,Offset1:LongInt; Begin If Primary Then Begin Offset:=0; Offset1:=0; End Else Begin Offset:=4; Offset1:=-4; End; EnterSQLProcessing; FDBProcs.SQLAllocStmt(FDBProcs.ahdbc,ahstmt); cc:=TableName; Try //Some DB2 Servers return a GPF here ... rc:=SQL_ERROR; If TableName<>'' Then Begin If Primary Then rc:=FDBProcs.SQLPrimaryKeys(ahstmt,Nil,0,Nil,0,cc,SQL_NTS) Else If @FDBProcs.SQLForeignKeys<>Nil Then rc:=FDBProcs.SQLForeignKeys(ahstmt,Nil,0,Nil,0,Nil,0,Nil,0,Nil,0,cc,SQL_NTS); End Else Begin If Primary Then rc:=FDBProcs.SQLPrimaryKeys(ahstmt,Nil,0,Nil,0,Nil,0) Else If @FDBProcs.SQLForeignKeys<>Nil Then rc:=FDBProcs.SQLForeignKeys(ahstmt,Nil,0,Nil,0,Nil,0,Nil,0,Nil,0,Nil,0); End; If rc=SQL_SUCCESS Then Begin FDBProcs.SQLNumResultCols(ahstmt,cols); If cols>8 Then cols:=8; For I := 0 To cols-1 Do FDBProcs.SQLBindCol(ahstmt, I + 1, SQL_C_CHAR, C[I], 255, OutLen[I]); rc:=FDBProcs.SQLFetch(ahstmt); While ((rc<>SQL_NO_DATA_FOUND)And(rc<>SQL_ERROR)) Do Begin If OutLen[3+Offset]<>SQL_NULL_DATA Then Begin Move(C[3+Offset],S[1],OutLen[3+Offset]); S[0]:=Chr(OutLen[3+Offset]); If S[Length(S)]=#0 Then If length(S)>0 Then dec(S[0]); If ((TableName='')Or(Not Primary)) Then Begin If OutLen[2+Offset+Offset1]<>SQL_NULL_DATA Then Begin Move(C[2+Offset+Offset1],S1[1],OutLen[2+Offset+Offset1]); S1[0]:=Chr(OutLen[2+Offset+Offset1]); If S1[Length(S1)]=#0 Then If length(S1)>0 Then dec(S1[0]); If not Primary Then Begin S:=S+'>'+S1; If OutLen[2+Offset+Offset1+1]<>SQL_NULL_DATA Then Begin Move(C[2+Offset+Offset1+1],S1[1],OutLen[2+Offset+Offset1+1]); S1[0]:=Chr(OutLen[2+Offset+Offset1+1]); If S1[Length(S1)]=#0 Then If length(S1)>0 Then dec(S1[0]); S:=S+'.'+S1; End; End Else S:=S1+'.'+S; End; End; List.Add(S); End; rc:=FDBProcs.SQLFetch(ahstmt); End; End; Except List.Clear; End; FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP); LeaveSQLProcessing; End; Procedure TTable.DoOpen; Var rc:SQLRETURN; s:String; fmode:Longword; Begin If Not FActive Then Exit; If Not FillDBProcs(FDBProcs) Then Begin LeaveSQLProcessing; ErrorBox(LoadNLSStr(SErrLoadingDB)); Active:=False; Exit; {Error} End; If Not FOpened Then Begin EnterSQLProcessing; Try If FBeforeOpen<>Nil Then FBeforeOpen(Self); FDBProcs.ahstmt:=0; FDBProcs.ahenv:=0; If AllocateDBEnvironment(FDBProcs)<>SQL_SUCCESS Then Begin LeaveSQLProcessing; ErrorBox(LoadNLSStr(SErrAllocDBEnv)+'.'+ SQLErrorText(FDBProcs,FDBProcs.ahenv,0,0)); Active:=False; Exit; End; {Connect To Server} FDBProcs.ahdbc:=0; If FDBProcs.SQLAllocConnect(FDBProcs.ahenv,FDBProcs.ahdbc)<>SQL_SUCCESS Then Begin LeaveSQLProcessing; ErrorBox(LoadNLSStr(SErrAllocDBConnect)+'.'+ SQLErrorText(FDBProcs,FDBProcs.ahenv,0,0)); DoClose; Exit; End; {Set autocommit OFF} If FDBProcs.SQLSetConnectOption(FDBProcs.ahdbc,SQL_AUTOCOMMIT,SQL_AUTOCOMMIT_OFF)<>SQL_SUCCESS Then Begin LeaveSQLProcessing; ErrorBox(LoadNLSStr(SErrSettingDBOpts)+'.'+ SQLErrorText(FDBProcs,FDBProcs.ahenv,0,0)); DoClose; Exit; End; {Connect} Try If FDBProcs.uid='' Then Begin If FDBProcs.pwd='' Then rc:=FDBProcs.SqlConnect(FDBProcs.ahdbc,FDBProcs.DataBase,SQL_NTS, Nil,0,Nil,0) Else rc:=FDBProcs.SqlConnect(FDBProcs.ahdbc,FDBProcs.DataBase,SQL_NTS, Nil,0,FDBProcs.pwd,SQL_NTS); End Else If FDBProcs.pwd='' Then Begin rc:=FDBProcs.SqlConnect(FDBProcs.ahdbc,FDBProcs.DataBase,SQL_NTS, FDBProcs.uid,SQL_NTS,Nil,0); End Else rc:= FDBProcs.SqlConnect(FDBProcs.ahdbc,FDBProcs.DataBase,SQL_NTS, FDBProcs.uid,SQL_NTS,FDBProcs.pwd,SQL_NTS); If rc<>SQL_SUCCESS Then Begin S:=SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,0); DoClose; SQLError(LoadNLSStr(SErrorDBConnecting)+' "'+DataBase+'".'+#13#10+S); End; Except ON E:ESQLError Do Begin LeaveSQLProcessing; ErrorBox(E.Message); Exit; End; Else Raise; End; FOpened:=True; LeaveSQLProcessing; If FAfterOpen<>Nil Then AfterOpen(Self); Except LeaveSQLProcessing; Raise; End; End; End; Procedure TTable.DoClose; Begin Try If FBeforeClose<>Nil Then FBeforeClose(Self); If FOpened Then Begin CloseStmt; Post; //Commit All transactions End; FActive:=False; FDataSetLocked:=True; FFieldDefs.Clear; FDataSetLocked:=False; If FDBProcs.ahdbc <> 0 Then Begin If FOpened Then If FDBProcs.SQLDisconnect(FDBProcs.ahdbc) <> SQL_SUCCESS Then ErrorBox('Disconnect error '+SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,0)); If FDBProcs.SQLFreeConnect(FDBProcs.ahdbc) <> SQL_SUCCESS Then ErrorBox('FreeConnect error '+SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,0)); FDBProcs.ahdbc := 0; End; If FDBProcs.ahenv <> 0 Then Begin If FDBProcs.SQLFreeEnv(FDBProcs.ahenv) <> SQL_SUCCESS Then ErrorBox('FreeEnv error '+SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,0)); FDBProcs.ahenv := 0; End; Inherited DoClose; DataChange(deDataBaseChanged); If FAfterClose<>Nil Then FAfterClose(Self); Except Raise; End; End; Procedure TTable.GetStoredProcNames(List:TStrings); Var ahstmt:SQLHSTMT; cols:SQLSMALLINT; I:LongInt; C:Array[0..4] Of cstring; OutLen:Array[0..4] Of SQLINTEGER; rc:SQLRETURN; S,S1:String; OldActive:Boolean; OldOpen:Boolean; Begin Inherited GetStoredProcNames(List); If ((ComponentState*[csReading]=[])And(Not FDataSetLocked)) Then Begin OldActive:=FActive; OldOpen:=FOpened; If Designed Then If Not FOpened Then Begin FActive:=True; DoOpen; If Not FOpened Then Active:=False; End; If FOpened Then Begin EnterSQLProcessing; FDBProcs.SQLAllocStmt(FDBProcs.ahdbc,ahstmt); If FDBProcs.SQLProcedures(ahstmt,Nil,0,Nil,0,Nil,0)=SQL_SUCCESS Then Begin FDBProcs.SQLNumResultCols(ahstmt,cols); If cols>3 Then cols:=3; For I := 0 To cols-1 Do FDBProcs.SQLBindCol(ahstmt, I + 1, SQL_C_CHAR, C[I], 255, OutLen[I]); rc:=FDBProcs.SQLFetch(ahstmt); While ((rc<>SQL_NO_DATA_FOUND)And(rc<>SQL_ERROR)) Do Begin If OutLen[2]<>SQL_NULL_DATA Then Begin Move(C[2],S[1],OutLen[2]); S[0]:=Chr(OutLen[2]); If S[length(S)]=#0 Then If length(S)>0 Then dec(S[0]); If OutLen[0]<>SQL_NULL_DATA Then Begin Move(C[0],S1[1],OutLen[0]); S1[0]:=Chr(OutLen[0]); If S1[length(S1)]=#0 Then If length(S1)>0 Then dec(S1[0]); If S1<>'' Then S:=S1+'.'+S; End; List.Add(S); End; rc:=FDBProcs.SQLFetch(ahstmt); End; End Else List.Clear; FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP); LeaveSQLProcessing; End; If Designed Then Begin If Not OldOpen Then DoClose; FActive:=OldActive; End; End; End; Procedure TTable.GetDataSources(List:TStrings); Var AliasName,DriverName,Advanced,UID:String; t,Count:LongInt; Begin List.Clear; If ((ComponentState*[csReading]=[])And(Not FDataSetLocked)) Then Begin Count:=GetDbAliasNamesCount; For t:=0 To Count-1 Do Begin GetDBAlias(t,AliasName,DriverName,Advanced,UID); List.Add(AliasName); End; End; End; Procedure TTable.DoDelete; Var C,c1:cstring; ahstmt,ahstmt1:SQLHSTMT; S:String; resultCols:SQLSMALLINT; rc:SQLRETURN; T:LongInt; T1,RowId:LongInt; Res:SQLINTEGER; OracleRowId:CString; Begin If ReadOnly Then SQLError('Cannot modify a readonly dataset!'); If (Not IsTable) Then exit; //cannot update this result set... EnterSQLProcessing; FDBProcs.SQLAllocStmt(FDBProcs.ahdbc,ahstmt); Case FDBProcs.DBType Of Native_mSQL: C:='SELECT _rowid,'+Fields[0].FieldName+' FROM '+TableName; Native_Oracle7: C:='SELECT ROWID,'+Fields[0].FieldName+' FROM '+TableName+' FOR UPDATE' Else C:='SELECT * FROM '+TableName+' FOR UPDATE'; End; If FDBProcs.SQLExecDirect(ahstmt,C,SQL_NTS)<>SQL_SUCCESS Then Begin S:=SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,ahstmt); FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP); SQLError('Error executing SELECT SQL statement: '+S); End; FDBProcs.SQLNumResultCols(ahstmt,resultCols); If resultCols=0 Then //Not A Select statement Begin FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP); LeaveSQLProcessing; Exit; End; If FDBProcs.DBType=Native_mSQL Then T1:=Fields[0].FRow-1 Else T1:=Fields[0].FRow; For T:=0 To T1 Do Begin rc:=FDBProcs.SQLFetch(ahstmt); If ((rc=SQL_NO_DATA_FOUND)Or(rc=SQL_ERROR)) Then Begin S:=SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,ahstmt); FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP); SQLError(LoadNLSStr(SErrorFetchingSQLStatement)+': '+S); End; End; If FDBProcs.DBType=Native_mSQL Then Begin If FDBProcs.SQLGetData(ahstmt,1,SQL_INTEGER,RowId,4,Res)<>SQL_SUCCESS Then Begin S:=SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,ahstmt); FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP); SQLError(LoadNLSStr(SErrorFetchingSQLStatement)+': '+S); End; End; If FDBProcs.DBType=Native_Oracle7 Then Begin If FDBProcs.SQLGetData(ahstmt,1,SQL_C_CHAR,OracleRowId,255,Res)<>SQL_SUCCESS Then Begin S:=SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,ahstmt); FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP); SQLError(LoadNLSStr(SErrorFetchingSQLStatement)+': '+S); End; End; FillChar(c1,255,0); If FDBProcs.SQLGetCursorName(ahstmt,c1,255,resultCols)<>SQL_SUCCESS Then Begin S:=SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,ahstmt); FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP); SQLError('Error executing SQLGetCursorName statement: '+S); End; If FDBProcs.DBType=Native_Oracle7 Then ahstmt1:=ahstmt Else Begin FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP); FDBProcs.SQLAllocStmt(FDBProcs.ahdbc,ahstmt1); End; S:='DELETE FROM '+TableName; Case FDBProcs.DBType Of Native_mSQL: S:=S+' WHERE _rowid='+tostr(RowId); Native_Oracle7: S:=S+' WHERE ROWID='+#39+OracleRowId+#39; Else S:=S+' WHERE CURRENT OF '+c1; End; C:=S; If FDBProcs.SQLExecDirect(ahstmt1,C,SQL_NTS)<>SQL_SUCCESS Then Begin S:=SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,ahstmt1); FDBProcs.SQLFreeStmt(ahstmt1,SQL_DROP); SQLError('Error executing SQL DELETE statement: '+S); End; FDBProcs.SQLFreeStmt(ahstmt1,SQL_DROP); LeaveSQLProcessing; Inherited DoDelete; End; Procedure TTable.CommitInsert(Commit:Boolean); Var ahstmt:SQLHSTMT; Ansi:AnsiString; S:String; T:LongInt; Field:TField; i:LongInt; Begin Inherited CommitInsert(Commit); If ReadOnly Then SQLError('Cannot modify a readonly dataset!'); If Commit Then Begin EnterSQLProcessing; FDBProcs.SQLAllocStmt(FDBProcs.ahdbc,ahstmt); Ansi:='INSERT INTO '+TableName+' ('; For T:=0 To FieldCount-1 Do Begin Ansi:=Ansi+FieldNames[T]; If T<>FieldCount-1 Then Ansi:=Ansi+','; End; Ansi:=Ansi+') VALUES('; For T:=0 To FieldCount-1 Do Begin Field:=Fields[T]; If Field.DataType=ftMemo Then Ansi:=Ansi+#39+PChar(Field.FValue)^+#39 Else Begin S:=Field2String(field); Ansi:=Ansi+S; End; If T<>FieldCount-1 Then Ansi:=Ansi+','; End; Ansi:=Ansi+')'; //ErrorBox2(PChar(Ansi)^); If FDBProcs.SQLExecDirect(ahstmt,PChar(Ansi)^,SQL_NTS)<>SQL_SUCCESS Then Begin S:=SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,ahstmt); FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP); SQLError('Error executing INSERT SQL statement: '+S); End; FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP); LeaveSQLProcessing; FRowIsInserted:=False; QueryTable; End Else Begin RemoveCurrentFields; RowInserted := False; End; End; Function TTable.UpdateFieldSelect(Field:TField):Boolean; Var ahstmt,ahstmt1:SQLHSTMT; resultCols:SQLSMALLINT; C,c1:cstring; rc:SQLRETURN; S:String; T,T1,RowId:LongInt; Res:SQLINTEGER; Ansi:AnsiString; OracleRowId:CString; Begin Result:=False; If Not FOpened Then Exit; If ((field=Nil)Or(FSelect.Count=0)) Then Exit; If FRowIsInserted Then Begin Result:=True; Exit; End; If ReadOnly Then SQLError('Cannot modify a readonly dataset!'); If (Not IsTable) Then exit; //cannot update this result set... EnterSQLProcessing; FDBProcs.SQLAllocStmt(FDBProcs.ahdbc,ahstmt); Case FDBProcs.DBType Of Native_mSQL: C:='SELECT _rowid,'+Field.FieldName+' FROM '+TableName; Native_Oracle7: C:='SELECT ROWID,'+Field.FieldName+' FROM '+TableName+' FOR UPDATE'; Else C:='SELECT * FROM '+TableName+' FOR UPDATE'; End; If FDBProcs.SQLExecDirect(ahstmt,C,SQL_NTS)<>SQL_SUCCESS Then Begin S:=SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,ahstmt); FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP); SQLError('Error executing SELECT SQL statement: '+S); End; FDBProcs.SQLNumResultCols(ahstmt,resultCols); If resultCols=0 Then //Not A Select statement Begin FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP); LeaveSQLProcessing; Exit; End; If FDBProcs.DBType=Native_mSQL Then T1:=Field.FRow-1 Else T1:=Field.FRow; For T:=0 To T1 Do Begin rc:=FDBProcs.SQLFetch(ahstmt); If ((rc=SQL_NO_DATA_FOUND)Or(rc=SQL_ERROR)) Then Begin S:=SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,ahstmt); FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP); SQLError(LoadNLSStr(SErrorFetchingSQLStatement)+': '+S); End; End; If FDBProcs.DBType=Native_mSQL Then Begin If FDBProcs.SQLGetData(ahstmt,1,SQL_INTEGER,RowId,4,Res)<>SQL_SUCCESS Then Begin S:=SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,ahstmt); FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP); SQLError(LoadNLSStr(SErrorFetchingSQLStatement)+': '+S); End; End; If FDBProcs.DBType=Native_Oracle7 Then Begin If FDBProcs.SQLGetData(ahstmt,1,SQL_C_CHAR,OracleRowId,255,Res)<>SQL_SUCCESS Then Begin S:=SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,ahstmt); FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP); SQLError(LoadNLSStr(SErrorFetchingSQLStatement)+': '+S); End; End; FillChar(c1,255,0); If FDBProcs.SQLGetCursorName(ahstmt,c1,255,resultCols)<>SQL_SUCCESS Then Begin S:=SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,ahstmt); FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP); SQLError('Error executing SQLGetCursorName statement: '+S); End; If FDBProcs.DBType=Native_Oracle7 Then ahstmt1:=ahstmt Else Begin FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP); FDBProcs.SQLAllocStmt(FDBProcs.ahdbc,ahstmt1); End; Ansi:='UPDATE '+TableName+' SET '+field.FieldName+'='; If Field.DataType=ftMemo Then Ansi:=Ansi+#39+PChar(Field.FValue)^+#39 Else Ansi:=Ansi+Field2String(field); Case FDBProcs.DBType Of Native_mSQL: Ansi:=Ansi+' WHERE _rowid='+tostr(RowId); Native_Oracle7: Ansi:=Ansi+' WHERE ROWID='+#39+OracleRowId+#39; Else Ansi:=Ansi+' WHERE CURRENT OF '+c1; End; If FDBProcs.SQLExecDirect(ahstmt1,PChar(Ansi)^,SQL_NTS)<>SQL_SUCCESS Then Begin S:=SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,ahstmt1); FDBProcs.SQLFreeStmt(ahstmt1,SQL_DROP); SQLError('Error executing SQL UPDATE statement: '+S); End; FDBProcs.SQLFreeStmt(ahstmt1,SQL_DROP); LeaveSQLProcessing; Result:=True; End; Procedure TTable.DoCancel; Begin FDBProcs.SQLTransact(FDBProcs.ahenv,FDBProcs.ahdbc,SQL_ROLLBACK); End; Procedure TTable.DoPost; Begin FDBProcs.SQLTransact(FDBProcs.ahenv,FDBProcs.ahdbc,SQL_COMMIT); End; Procedure TTable.CloseStmt; Var I:LongInt; Begin If Not FOpened Then Exit; {Free statement Handle} If FDBProcs.ahstmt<>0 Then Begin FDBProcs.SQLFreeStmt(FDBProcs.ahstmt,SQL_DROP); FDBProcs.ahstmt:=0; End; End; Procedure TTable.UpdateIndexDefs; Var ahstmt:SQLHSTMT; cols:SQLSMALLINT; I:LongInt; C:Array[0..9] Of cstring; OutLen:Array[0..9] Of SQLINTEGER; rc:SQLRETURN; S,S1,Fields:String; OldActive:Boolean; OldOpen:Boolean; IndexDef:TIndexDef; Begin If FIndexDefs<>Nil Then FIndexDefs.Clear Else FIndexDefs.Create(Self); If FIndexFieldMap<>Nil Then FIndexFieldMap.Clear; If (Not IsTable) Then SQLError('Illegal operation'); If ((ComponentState*[csReading]=[])And(Not FDataSetLocked)) Then Begin OldActive:=FActive; OldOpen:=FOpened; If Not FOpened Then Begin FActive:=True; DoOpen; If Not FOpened Then Active:=False; End; If FOpened Then If @FDBProcs.SQLStatistics<>Nil Then Begin EnterSQLProcessing; FDBProcs.SQLAllocStmt(FDBProcs.ahdbc,ahstmt); If FDBProcs.SQLStatistics(ahstmt,Nil,0,Nil,0,TableName,SQL_NTS,SQL_INDEX_ALL,SQL_ENSURE)=SQL_SUCCESS Then Begin FDBProcs.SQLNumResultCols(ahstmt,cols); If cols>9 Then cols:=9; For I := 0 To cols-1 Do FDBProcs.SQLBindCol(ahstmt, I + 1, SQL_C_CHAR, C[I], 255, OutLen[I]); rc:=FDBProcs.SQLFetch(ahstmt); While ((rc<>SQL_NO_DATA_FOUND)And(rc<>SQL_ERROR)) Do Begin If OutLen[5]<>SQL_NULL_DATA Then Begin Move(C[5],S[1],OutLen[5]); S[0]:=Chr(OutLen[5]); If S[length(s)]=#0 Then If length(S)>0 Then dec(S[0]); If OutLen[4]<>SQL_NULL_DATA Then Begin Move(C[4],S1[1],OutLen[4]); S1[0]:=Chr(OutLen[4]); If S1[length(S1)]=#0 Then If length(S1)>0 Then dec(S1[0]); If S1<>'' Then S:=S1+'.'+S; End; //get column name If OutLen[8]<>SQL_NULL_DATA Then Begin Move(C[8],Fields[1],OutLen[8]); Fields[0]:=Chr(OutLen[8]); If Fields[length(Fields)]=#0 Then If length(Fields)>0 Then dec(Fields[0]); End; If ((s<>'')And(Fields<>'')) Then Begin If FIndexDefs.IndexOf(s)>=0 Then Begin IndexDef:=FIndexDefs.Items[FIndexDefs.IndexOf(s)]; AssignStr(IndexDef.FFields,IndexDef.Fields+';'+Fields); End Else FIndexDefs.Add(s,Fields,[]); End; End; rc:=FDBProcs.SQLFetch(ahstmt); End; End Else Begin S:=SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,ahstmt); FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP); DataBaseError(s); End; FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP); LeaveSQLProcessing; End; If Not OldOpen Then DoClose; FActive:=OldActive; End; End; Procedure TTable.UpdateFieldDefs; Begin QueryTable; End; Procedure TTable.QueryTable; Var resultCols:SQLSMALLINT; colName:cstring; colNameLen:SQLSMALLINT; colType:SQLSMALLINT; Size:SQLUINTEGER; Scale:SQLSMALLINT; I:LongInt; S:String; Select:PChar; Temp:TStringList; t2:String; J,j1:String; First:Boolean; B:Byte; field:TField; MasterTable:TTable; rc:SQLRETURN; pfNullable:SQLSMALLINT; FieldDef:TFieldDef; Label lll; Begin If Not FOpened Then Exit; //Erase All tables And Reset Object CloseStmt; FFieldDefs.Clear; FCurrentRow:=-1; FCurrentField:=0; If ((Self Is TTable)And(TTable(Self).FMasterSource<>Nil)And (TTable(Self).FMasterSource.DataSet Is TTable)) Then Begin Temp.Create; t2:=TTable(TTable(Self).FMasterSource.DataSet).TableName; Temp.Add('SELECT * FROM '+TableName); S:=TTable(Self).MasterFields; First:=True; MasterTable:=TTable(TTable(Self).FMasterSource.DataSet); While S<>'' Do Begin B:=Pos(';',S); If B<>0 Then Begin J:=Copy(S,1,B-1); System.Delete(S,1,B); End Else Begin J:=S; S:=''; End; B:=Pos('=',J); If B<>0 Then Begin j1:=System.Copy(J,B+1,255); J[0]:=Chr(B-1); End Else j1:=J; field:=MasterTable.FieldFromColumnName[j1]; If field=Nil Then Begin Temp.Destroy; Goto lll; End; j1:=Field2String(field); If First Then Temp.Add('WHERE '+J+'='+j1) Else Temp.Add('AND '+J+'='+j1); First:=False; End; Select:=Temp.GetText; Temp.Destroy; End Else Begin lll: Select:=FSelect.GetText; End; If Select=Nil Then Begin DoClose; Exit; End; While ((Select^<>'')And(Select^[length(Select^)-1] In [#13,#10])) Do Select^[length(Select^)-1]:=#0; EnterSQLProcessing; FDBProcs.SQLAllocStmt(FDBProcs.ahdbc,FDBProcs.ahstmt); Try If FDBProcs.SQLExecDirect(FDBProcs.ahstmt,Select^,SQL_NTS)<>SQL_SUCCESS Then Begin S:=SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,FDBProcs.ahstmt); CloseStmt; DoClose; SQLError('Error executing SELECT statement: '+S); End; {The driver determines the number of rows in the result set} rc:=FDBProcs.SQLFetch(FDBProcs.ahstmt); FMaxRows:=0; While ((rc<>SQL_NO_DATA_FOUND)And(rc<>SQL_ERROR)) Do Begin inc(FMaxRows); rc:=FDBProcs.SQLFetch(FDBProcs.ahstmt); End; FDBProcs.SQLFreeStmt(FDBProcs.ahstmt,SQL_DROP); FDBProcs.ahstmt:=0; {The driver recreates the result set} FDBProcs.SQLAllocStmt(FDBProcs.ahdbc,FDBProcs.ahstmt); FDBProcs.SQLSetStmtOption(FDBProcs.ahstmt,SQL_CURSOR_TYPE,SQL_CURSOR_KEYSET_DRIVEN); If FDBProcs.SQLExecDirect(FDBProcs.ahstmt,Select^,SQL_NTS)<>SQL_SUCCESS Then Begin S:=SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,FDBProcs.ahstmt); CloseStmt; DoClose; SQLError(LoadNLSStr(SErrorExecutingSQLStatement)+': '+S); End; {The driver determines the result set columns} FDBProcs.SQLNumResultCols(FDBProcs.ahstmt,resultCols); If resultCols=0 Then //Not A Select statement Begin CloseStmt; SQLError(LoadNLSStr(SEmptyResultSet)); End Else Begin {Store Result Columns} For I := 0 To resultCols-1 Do Begin Size:=0; FDBProcs.SQLDescribeCol(FDBProcs.ahstmt, I + 1, colName, SizeOf(colName), colNameLen, colType, Size, Scale, pfNullable); If Size>65535 Then Size:=4096; S:=colName; Case ColType Of SQL_REAL:Size:=4; SQL_FLOAT,SQL_DOUBLE,SQL_NUMERIC:Size:=8; End; //case FFieldDefs.Add(S, MapSQLType(colType), Size, pfNullable=SQL_NO_NULLS); FieldDef := FFieldDefs[I]; FieldDef.Precision := Scale; End; FCurrentRow:=0; {First Row} FCurrentField:=0; {First field} End; Post; //Commit All transactions Until here StrDispose(Select); LeaveSQLProcessing; Except ON E:ESQLError Do Begin StrDispose(Select); CloseStmt; LeaveSQLProcessing; ErrorBox(E.Message); End; Else Begin StrDispose(Select); CloseStmt; LeaveSQLProcessing; Raise; End; End; DataChange(deDataBaseChanged); End; { ษอออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออป บ บ บ Speed-Pascal/2 Version 2.0 บ บ บ บ Speed-Pascal Component Classes (SPCC) บ บ บ บ This section: TQuery Class Implementation บ บ บ บ (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! บ บ บ ศอออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออผ } Procedure TQuery.RefreshTable; Begin If ((ComponentState*[csReading]<>[])Or(FDataSetLocked)) Then Begin FRefreshOnLoad:=FActive; Exit; End; DoOpen; If Not FOpened Then Exit; If FSelect.Count<>0 Then QueryTable; End; Procedure TQuery.SetSQL(NewValue:TStrings); Begin If ((NewValue=FSelect)Or(NewValue.Equals(FSelect))) Then Exit; {!} FSelect.Assign(NewValue); If FActive Then RefreshTable; End; Procedure TQuery.SetupComponent; Begin Inherited SetupComponent; ReadOnly:=True; Name:='Query'; End; Function TQuery.WriteSCUResource(Stream:TResourceStream):Boolean; Var aText:PChar; Begin Result:=Inherited WriteSCUResource(Stream); If Result=False Then Exit; aText:=FSelect.GetText; If aText<>Nil Then Begin Result:=Stream.NewResourceEntry(rnDBQuery,aText^,Length(aText^)+1); StrDispose(aText); End; End; Procedure TQuery.ReadSCUResource(Const ResName:TResourceName;Var Data;DataLen:LongInt); Var aText:PChar; Begin If ResName = rnDBQuery Then Begin aText:=@Data; FSelect.SetText(aText); End Else Inherited ReadSCUResource(ResName,Data,DataLen) End; { ษอออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออป บ บ บ Speed-Pascal/2 Version 2.0 บ บ บ บ Speed-Pascal Component Classes (SPCC) บ บ บ บ This section: TParam Class Implementation บ บ บ บ (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! บ บ บ ศอออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออผ } Procedure TParam.SetAsBCD(Value: Currency); Begin FNull := False; FBound := True; FData:=Value; End; Procedure TParam.SetAsBoolean(Value: Boolean); Begin FNull := False; FBound := True; FData:=Value; End; Procedure TParam.SetAsCurrency(Value:Extended); Begin FNull := False; FBound := True; FData:=Value; End; Procedure TParam.SetAsDate(Value: TDateTime); Begin FNull := False; FBound := True; FData:=Value; End; Procedure TParam.SetAsDateTime(Value: TDateTime); Begin FNull := False; FBound := True; FData:=Value; End; Procedure TParam.SetAsFloat(Const Value:Extended); Begin FNull := False; FBound := True; FData:=Value; End; Procedure TParam.SetAsInteger(Value: Longint); Begin FNull := False; FBound := True; FData:=Value; End; Procedure TParam.SetAsString(Const Value:String); Begin FNull := False; FBound := True; FData:=Value; End; Procedure TParam.SetAsSmallInt(Value: LongInt); Begin FNull := False; FBound := True; FData:=Value; End; Procedure TParam.SetAsTime(Value: TDateTime); Begin FNull := False; FBound := True; FData:=Value; End; Procedure TParam.SetAsVariant(Value: Variant); Begin FNull := False; FBound := True; Case VarType(Value) Of varByte,varSmallint:DataType:=ftSmallInt; varInteger,varLongInt,varLongWord:DataType:=ftInteger; varCurrency:DataType:=ftBCD; varSingle,varDouble,varExtended:DataType:=ftFloat; varBoolean:DataType:=ftBoolean; varString:DataType:=ftString; Else DataType := ftUnknown; End; FData := Value; End; Procedure TParam.SetAsWord(Value: LongInt); Begin FNull := False; FBound := True; FData:=Value; End; Function TParam.GetAsBCD: Currency; Begin Result:=FData; End; Function TParam.GetAsBoolean: Boolean; Begin Result:=FData; End; Function TParam.GetAsDateTime: TDateTime; Begin Result:=FData; End; Function TParam.GetAsFloat:Extended; Begin Result:=FData; End; Function TParam.GetAsInteger: Longint; Begin Result:=FData; End; Function TParam.GetAsString:String; Begin Result:=FData; End; Function TParam.GetAsVariant: Variant; Begin Result:=FData; End; Function TParam.IsEqual(Value: TParam): Boolean; Begin result:=False; If ParamType=Value.ParamType Then If Bound=Value.Bound Then If VarType(FData)=VarType(Value.FData) Then If Name=Value.Name Then If FData=Value.FData Then result:=True; End; Procedure TParam.SetDataType(Value: TFieldType); Begin FData := 0; FDataType := Value; End; Procedure TParam.SetText(Const Value:String); Begin FNull := False; FBound := True; If FDataType=ftUnknown Then DataType:=ftString; FData := Value; Case DataType of ftBoolean:FData:=Boolean(FData); ftInteger,ftSmallInt,ftWord: FData := Integer(FData); ftDateTime,ftTime,ftDate:FData:=Extended(FData); ftBCD:FData:=Currency(FData); ftCurrency,ftFloat:FData:=Extended(FData); End; End; Constructor TParam.Create(AParamList:TParams;AParamType: TParamType); Begin FParamList:=AParamList; If FParamList<>Nil Then FParamList.AddParam(Self); FParamType := AParamType; DataType := ftUnknown; FBound := False; End; Destructor TParam.Destroy; Begin If FParamList<>Nil Then FParamList.RemoveParam(Self); If FName<>Nil Then FreeMem(FName,length(FName^)+1); Inherited Destroy; End; Function TParam.GetName:String; Begin If FName=Nil Then result:='' Else Result:=FName^; End; Procedure TParam.SetName(Const NewValue:String); Begin If FName<>Nil Then FreeMem(FName,length(FName^)+1); GetMem(FName,length(NewValue)+1); FName^:=NewValue; End; Procedure TParam.Assign(Param: TParam); Begin If Param=Nil Then exit; DataType:=Param.DataType; If not Param.IsNull Then Begin FNull := False; FBound := True; FData := Param.FData; End Else Clear; Name:=Param.Name; FBound:=Param.Bound; If FParamType=ptUnknown Then FParamType:=Param.ParamType; End; Procedure TParam.AssignField(Field: TField); Begin If Field=Nil Then exit; DataType:=Field.DataType; If not Field.IsNull Then Begin FNull := False; FBound := True; FData := Field.AsString; End Else Clear; Name:=Field.FieldName; FBound:=True; End; Procedure TParam.AssignFieldValue(Field:TField;Const Value: Variant); Begin If Field=Nil Then exit; DataType := Field.DataType; If VarIsNull(Value) Then Clear Else Begin FNull := False; FBound := True; FData := Value; End; FBound := True; End; Procedure TParam.Clear; Begin FData:=0; FNull:=True; End; { ษอออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออป บ บ บ Speed-Pascal/2 Version 2.0 บ บ บ บ Speed-Pascal Component Classes (SPCC) บ บ บ บ This section: TParams Class Implementation บ บ บ บ (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! บ บ บ ศอออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออผ } Function TParams.GetParam(Index: Word): TParam; Begin result:=FItems[Index]; End; Function TParams.GetParamValue(Const ParamName:String): Variant; Var Param:TParam; Begin Param:=ParamByName(ParamName); If Param<>Nil Then Result:=Param.Value; End; Procedure TParams.SetParamValue(Const ParamName:String;Const Value: Variant); Var Param:TParam; Begin Param:=ParamByName(ParamName); If Param<>Nil Then Param.Value:=Value; End; Constructor TParams.Create; Begin Inherited Create; FItems.Create; End; Destructor TParams.Destroy; Begin Clear; FItems.Destroy; Inherited Destroy; End; Procedure TParams.AddParam(Value: TParam); Begin FItems.Add(Value); End; Procedure TParams.RemoveParam(Value: TParam); Begin FItems.Remove(Value); If Value.FParamList=Self Then Value.FParamList:=Nil; End; Function TParams.CreateParam(FldType:TFieldType;Const ParamName:String;ParamType: TParamType): TParam; Begin Result.Create(Self,ParamType); Result.Name:=ParamName; Result.DataType := FldType; End; Function TParams.Count:LongInt; Begin Result:=FItems.Count; End; Procedure TParams.Clear; Var t:LongInt; Param:TParam; Begin For t:=FItems.Count-1 DownTo 0 Do Begin Param:=FItems[t]; Param.Destroy; End; End; Function TParams.IsEqual(Value:TParams): Boolean; Var t:LongInt; Begin Result:=False; If FItems.Count=Value.Count Then For t:=0 To FItems.Count-1 Do If not Items[t].IsEqual(Value.Items[t]) Then exit; End; Function TParams.ParamByName(Const Value:String):TParam; Var t:LongInt; Begin For t:=0 To FItems.Count - 1 Do Begin Result:=FItems[t]; If Result.Name=Value Then Exit; End; DatabaseError('Invalid stored procedure parameter name: '+Value); End; { ษอออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออป บ บ บ Speed-Pascal/2 Version 2.0 บ บ บ บ Speed-Pascal Component Classes (SPCC) บ บ บ บ This section: TStoredProc Class Implementation บ บ บ บ (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! บ บ บ ศอออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออออผ } Function TStoredProc.GetParamCount:Word; Begin Result:=FParams.Count; End; Procedure TStoredProc.SetDefaultParams; Var ahstmt:SQLHSTMT; cols:SQLSMALLINT; I,t:LongInt; C:Array[0..12] Of cstring; OutLen:Array[0..12] Of SQLINTEGER; si:SQLSMALLINT; rc:SQLRETURN; S:String; Cs:CString; OldActive:Boolean; OldOpen:Boolean; pt:TParamType; ft:TFieldType; cc:Integer; Names:TStringList; Types,Modes:TList; Label weiter; Begin //determine parameter from driver FParams.Clear; If ((ComponentState*[csReading]=[])And(Not FDataSetLocked)) Then If StoredProcName<>'' Then Begin OldActive:=FActive; OldOpen:=FOpened; If Designed Then If Not FOpened Then Begin FActive:=True; DoOpen; If Not FOpened Then Active:=False; End; If FOpened Then Begin If FDBProcs.DBType=Native_Oracle7 Then Begin Names.Create; Types.Create; Modes.Create; If not FDBProcs.Oracle7GetProcParams(FProcName,@FDBProcs,Names,Types,Modes) Then Begin ErrorBox(SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,FDBProcs.ahstmt)); End Else Begin For t:=0 To Names.Count-1 Do Begin i:=LongInt(Types[t]); ft:=MapSQLType(i); i:=LongInt(Modes[t]); If i>=16 Then pt:=ptResult Else Case i Of 0:pt:=ptInput; 1:pt:=ptOutput; Else pt:=ptInputOutput; End; //case FParams.CreateParam(ft,Names[t],pt); End; End; Names.Destroy; Types.Destroy; Modes.Destroy; End Else Begin EnterSQLProcessing; FDBProcs.SQLAllocStmt(FDBProcs.ahdbc,ahstmt); Cs:=FProcName; If FDBProcs.SQLProcedureColumns(ahstmt,Nil,0,Nil,0,Cs,length(FProcName),Nil,0)=SQL_SUCCESS Then Begin FDBProcs.SQLNumResultCols(ahstmt,cols); If cols>13 Then cols:=13; For I := 0 To cols-1 Do FDBProcs.SQLBindCol(ahstmt, I + 1, SQL_C_CHAR, C[I], 255, OutLen[I]); rc:=FDBProcs.SQLFetch(ahstmt); While ((rc<>SQL_NO_DATA_FOUND)And(rc<>SQL_ERROR)) Do Begin If OutLen[3]<>SQL_NULL_DATA Then //Parameter name Begin Move(C[4],S[1],OutLen[4]); //Parameter type S[0]:=Chr(OutLen[4]); Val(S,si,cc); If cc<>0 Then goto weiter; //illegal Case si Of SQL_PARAM_INPUT:pt:=ptInput; SQL_PARAM_OUTPUT:pt:=ptOutput; SQL_PARAM_INPUT_OUTPUT:pt:=ptInputOutput; SQL_RETURN_VALUE:pt:=ptResult; SQL_RESULT_COL:pt:=ptResultSet; Else pt:=ptUnknown; End; Move(C[5],S[1],OutLen[5]); //Parameter data type S[0]:=Chr(OutLen[5]); Val(S,si,cc); If cc<>0 Then goto weiter; //illegal ft:=MapSQLType(si); Move(C[3],S[1],OutLen[3]); S[0]:=Chr(OutLen[3]); FParams.CreateParam(ft,S,pt); End; weiter: rc:=FDBProcs.SQLFetch(ahstmt); End; End; FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP); LeaveSQLProcessing; End; End; If Designed Then Begin If Not OldOpen Then DoClose; FActive:=OldActive; End; End; End; Procedure TStoredProc.SetPrepared(NewValue:Boolean); Begin If not NewValue Then Begin FPrepared:=False; exit; End; If ((ComponentState*[csReading]=[])And(Not FDataSetLocked)) Then DoOpen; If FOpened Then FDBProcs.SQLAllocStmt(FDBProcs.ahdbc,FDBProcs.ahstmt); FPrepared:=True; End; Procedure TStoredProc.SetParams(NewValue:TParams); Var t:LongInt; Begin FParams.Clear; For t:=0 To NewValue.Count-1 Do FParams.CreateParam(NewValue[t].DataType,NewValue[t].Name,NewValue[t].ParamType); End; Procedure TStoredProc.SetStoredProcName(NewValue:String); Begin CheckInactive; FProcName:=NewValue; FParams.Clear; End; Constructor TStoredProc.Create(AOwner: TComponent); Begin Inherited Create(AOwner); ReadOnly:=True; Name:='StoredProc'; FParams.Create; End; Destructor TStoredProc.Destroy; Begin FParams.Destroy; Inherited Destroy; End; Procedure TStoredProc.CopyParams(Value:TParams); Begin Params:=Value; End; Procedure TStoredProc.ExecProc; Var rc:SQLRETURN; ReturnsResultSet:Boolean; t:LongInt; Param:TParam; s:String; c:CString; resultCols:SQLSMALLINT; I:LongInt; Size:SQLUINTEGER; colName:CString; colNameLen:SQLSMALLINT; colType:SQLSMALLINT; Scale:SQLSMALLINT; FieldDef:TFieldDef; ptsql,ctype,sqltype,Len:SQLSMALLINT; p:Pointer; Function ExecSQL:SQLRETURN; Var s:String; c:CString; t:LongInt; Begin If FDBProcs.DBType=Native_Oracle7 Then s:=StoredProcName+'(' Else s:='call '+StoredProcName+'('; For t:=0 To FParams.Count-1 Do Begin Param:=FParams[t]; If Param.ParamType=ptResultSet Then Begin ReturnsResultSet:=True; continue; End; If FDBProcs.DBType=Native_Oracle7 Then Begin If ((Param.ParamType=ptResult)And(s[1]<>':')) Then s:=':p0='+s Else Begin If s[length(s)]<>'(' Then s:=s+','; s:=s+':p'+tostr(t+1); End; End Else Begin If ((Param.ParamType=ptResult)And(s[1]<>'?')) Then s:='?='+s Else Begin If s[length(s)]<>'(' Then s:=s+','; s:=s+'?'; End; End; End; If FDBProcs.DBType=Native_Oracle7 Then s:='BEGIN'+#10+s+');'#10+'END;' Else s:='{'+s+')}'; c:=s; Result:=FDBProcs.SQLExecDirect(FDBProcs.ahstmt,c,SQL_NTS); End; Procedure BindParameters; Var i:LongInt; Param:TParam; Begin For i:=0 To FParams.Count-1 Do Begin Param:=FParams[i]; Case Param.ParamType Of ptInput:ptsql:=SQL_PARAM_INPUT; ptOutput:ptsql:=SQL_PARAM_OUTPUT; ptResult: Begin If FDBProcs.DBType=Native_Oracle7 Then ptsql:=SQL_PARAM_RESULT Else ptsql:=SQL_PARAM_OUTPUT; End; ptInputOutput:ptsql:=SQL_PARAM_INPUT_OUTPUT; Else Continue; //Next Parameter End; Case Param.DataType Of ftString: Begin sqlType:=SQL_CHAR; cType:=SQL_C_CHAR; p:=@Param.FResultNTS; Param.FResultNTS:=Param.AsString; Len:=Length(Param.FResultNTS); Param.FOutLen:=SQL_NTS; End; ftCurrency: Begin sqlType:=SQL_NUMERIC; cType:=SQL_C_FLOAT; Len:=10; p:=@Param.FResultExtended; Param.FResultExtended:=Param.AsFloat; Param.FOutLen:=10; End; ftInteger: Begin sqlType:=SQL_INTEGER; cType:=SQL_C_LONG; Len:=4; p:=@Param.FResultLongInt; Param.FResultLongInt:=Param.AsInteger; Param.FOutLen:=4; End; ftSmallInt: Begin sqlType:=SQL_SMALLINT; cType:=SQL_C_SHORT; Len:=2; p:=@Param.FResultSmallInt; Param.FResultSmallInt:=Param.AsSmallInt; Param.FOutLen:=2; End; ftFloat: Begin sqlType:=SQL_FLOAT; cType:=SQL_C_FLOAT; Len:=10; p:=@Param.FResultExtended; Param.FResultExtended:=Param.AsFloat; Param.FOutLen:=10; End; ftDate: Begin sqlType:=SQL_DATE; cType:=SQL_C_DATE; Len:=sizeof(Param.FResultDate); p:=@Param.FResultDate; DecodeDate(Param.AsDate,Param.FResultDate.Year,Param.FResultDate.Month,Param.FResultDate.Day); Param.FOutLen:=sizeof(Param.FResultDate); End; ftTime: Begin sqlType:=SQL_TIME; cType:=SQL_C_TIME; Len:=sizeof(Param.FResultTime); p:=@Param.FResultTime; RoundDecodeTime(Param.AsTime,Param.FResultTime.Hour,Param.FResultTime.Minute,Param.FResultTime.Second); Param.FOutLen:=sizeof(Param.FResultTime); End; ftDateTime: Begin sqlType:=SQL_TIMESTAMP; cType:=SQL_C_TIMESTAMP; Len:=sizeof(Param.FResultDateTime); p:=@Param.FResultDateTime; DecodeDate(Param.AsDate,Param.FResultDateTime.Year,Param.FResultDateTime.Month,Param.FResultDateTime.Day); RoundDecodeTime(Param.AsTime,Param.FResultDateTime.Hour,Param.FResultDateTime.Minute,Param.FResultDateTime.Second); Param.FOutLen:=sizeof(Param.FResultDateTime); End; ftMemo: Begin sqlType:=SQL_LONGVARCHAR; cType:=SQL_C_CHAR; Len:=0; //?? p:=Nil; //??? Param.FOutLen:=0; //?? current len End; ftBlob: Begin sqlType:=SQL_VARBINARY; cType:=SQL_C_BINARY; Len:=0; //?? p:=Nil; //??? Param.FOutLen:=0; //?? current len End; ftGraphic: Begin sqlType:=SQL_VARGRAPHIC; cType:=SQL_C_BINARY; Len:=0; //?? p:=Nil; //??? Param.FOutLen:=0; //?? current len End; End; //case Try rc:=FDBProcs.SQLBindParameter(FDBProcs.ahstmt,i+1,ptsql,ctype,sqltype,Len,0,p^,Len,Param.FOutLen); If rc=SQL_ERROR Then Begin S:=SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,FDBProcs.ahstmt); CloseStmt; DoClose; SQLError(LoadNLSStr(SErrorExecutingSQLStatement)+': '+S); End; Except ON E:ESQLError Do Begin CloseStmt; ErrorBox(E.Message); End; Else Begin CloseStmt; Raise; End; End; If FDBProcs.ahstmt=0 Then Begin DoClose; exit; End; End; End; Label err; Begin If not Prepared Then Prepare; CloseStmt; //if previous proc returned a result set... FMaxRows:=0; If not FOpened Then DoOpen; If FOpened Then Begin FDBProcs.SQLAllocStmt(FDBProcs.ahdbc,FDBProcs.ahstmt); If FDBProcs.SQLSetStmtOption(FDBProcs.ahstmt,SQL_CURSOR_TYPE,SQL_CURSOR_KEYSET_DRIVEN)=SQL_ERROR THEN Begin //S:=SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,FDBProcs.ahstmt); //ErrorBox(S); End; End Else exit; If FDBProcs.DBType=Native_Oracle7 Then Begin rc:=ExecSQL; If rc=SQL_ERROR Then goto err; End; //Bind Parameters BindParameters; If FDBProcs.ahstmt=0 Then Begin DoClose; exit; End; FFieldDefs.Clear; FCurrentRow:=-1; FCurrentField:=0; ReturnsResultSet:=False; EnterSQLProcessing; If FDBProcs.DBType<>Native_Oracle7 Then rc:=ExecSQL Else rc:=FDBProcs.SQLFetch(FDBProcs.ahstmt); If rc<>SQL_ERROR Then Begin For i:=0 To FParams.Count-1 Do Begin Param:=FParams[i]; If Param.ParamType<>ptOutput Then If Param.ParamType<>ptInputOutput Then If Param.ParamType<>ptResult Then continue; Case Param.DataType Of ftString: Begin Param.AsString:=Param.FResultNTS; End; ftCurrency: Begin Param.AsFloat:=Param.FResultExtended; End; ftInteger: Begin Param.AsInteger:=Param.FResultLongInt; End; ftSmallInt: Begin Param.AsSmallInt:=Param.FResultSmallInt; End; ftFloat: Begin Param.AsFloat:=Param.FResultExtended; End; ftDate: Begin Param.AsDate:=EncodeDate(Param.FResultDate.Year,Param.FResultDate.Month,Param.FResultDate.Day); End; ftTime: Begin Param.AsTime:=EncodeTime(Param.FResultTime.Hour,Param.FResultTime.Minute,Param.FResultTime.Second,0); End; ftDateTime: Begin Param.AsDateTime:=EncodeDate(Param.FResultDateTime.Year,Param.FResultDateTime.Month,Param.FResultDateTime.Day) + EncodeTime(Param.FResultDateTime.Hour,Param.FResultDateTime.Minute,Param.FResultDateTime.Second, 0); End; ftMemo: Begin End; ftBlob: Begin End; ftGraphic: Begin End; End; //case End; //for If ReturnsResultSet Then Begin {The driver determines the number of rows in the result set} rc:=FDBProcs.SQLFetch(FDBProcs.ahstmt); FMaxRows:=0; While ((rc<>SQL_NO_DATA_FOUND)And(rc<>SQL_ERROR)) Do Begin inc(FMaxRows); rc:=FDBProcs.SQLFetch(FDBProcs.ahstmt); End; FDBProcs.SQLFreeStmt(FDBProcs.ahstmt,SQL_DROP); FDBProcs.ahstmt:=0; {The driver recreates the result set} FDBProcs.SQLAllocStmt(FDBProcs.ahdbc,FDBProcs.ahstmt); If FDBProcs.SQLSetStmtOption(FDBProcs.ahstmt,SQL_CURSOR_TYPE,SQL_CURSOR_KEYSET_DRIVEN)=SQL_ERROR THEN Begin //S:=SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,FDBProcs.ahstmt); //ErrorBox(S); End; BindParameters; If FDBProcs.ahstmt=0 Then Begin DoClose; LeaveSQLProcessing; exit; End; rc:=FDBProcs.SQLExecDirect(FDBProcs.ahstmt,c,SQL_NTS); If rc=SQL_ERROR Then goto err; Try FDBProcs.SQLNumResultCols(FDBProcs.ahstmt,resultCols); If resultCols=0 Then //Not A Select statement Begin CloseStmt; SQLError(LoadNLSStr(SEmptyResultSet)); End Else Begin {Store Result Columns} For I := 0 To resultCols-1 Do Begin Size:=0; FDBProcs.SQLDescribeCol(FDBProcs.ahstmt, I + 1, colName, SizeOf(colName), colNameLen, colType, Size, Scale, Nil); If Size>65535 Then Size:=4096; S:=colName; Case ColType Of SQL_REAL:Size:=4; SQL_FLOAT,SQL_DOUBLE,SQL_NUMERIC:Size:=8; End; //case FFieldDefs.Add(S, MapSQLType(colType), Size, False); FieldDef := FFieldDefs[I]; FieldDef.Precision := Scale; End; FCurrentRow:=0; {First Row} FCurrentField:=0; {First field} End; Post; //Commit All transactions Until here DataChange(deDataBaseChanged); Except ON E:ESQLError Do Begin CloseStmt; LeaveSQLProcessing; ErrorBox(E.Message); End; Else Begin CloseStmt; LeaveSQLProcessing; Raise; End; End; //for result sets the statement must remain open... End Else CloseStmt; LeaveSQLProcessing; End Else Begin err: LeaveSQLProcessing; Try S:=SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,FDBProcs.ahstmt); CloseStmt; SQLError(LoadNLSStr(SErrorExecutingSQLStatement)+': '+S); Except ON E:ESQLError Do Begin CloseStmt; ErrorBox(E.Message); End; Else Begin CloseStmt; Raise; End; End; End; End; Function TStoredProc.ParamByName(Const Value:String):TParam; Begin Result := FParams.ParamByName(Value); End; Procedure TStoredProc.Prepare; Begin If FParams.Count=0 Then SetDefaultParams; Prepared:=True; End; Procedure TStoredProc.UnPrepare; Begin Prepared:=False; End; Procedure TStoredProc.DoOpen; Var rc:SQLRETURN; S:String; Begin If Not FActive Then Exit; If Not FillDBProcs(FDBProcs) Then Begin ErrorBox(LoadNLSStr(SErrLoadingDB)); Active:=False; Exit; {Error} End; FDBProcs.IsStoredProc:=True; If Not FOpened Then Begin Try If FBeforeOpen<>Nil Then FBeforeOpen(Self); FDBProcs.ahstmt:=0; FDBProcs.ahenv:=0; If AllocateDBEnvironment(FDBProcs)<>SQL_SUCCESS Then Begin ErrorBox(LoadNLSStr(SErrAllocDBEnv)+'.'+ SQLErrorText(FDBProcs,FDBProcs.ahenv,0,0)); Active:=False; Exit; End; {Connect To Server} FDBProcs.ahdbc:=0; If FDBProcs.SQLAllocConnect(FDBProcs.ahenv,FDBProcs.ahdbc)<>SQL_SUCCESS Then Begin ErrorBox(LoadNLSStr(SErrAllocDBConnect)+'.'+ SQLErrorText(FDBProcs,FDBProcs.ahenv,0,0)); DoClose; Exit; End; {Set autocommit OFF} If FDBProcs.SQLSetConnectOption(FDBProcs.ahdbc,SQL_AUTOCOMMIT,SQL_AUTOCOMMIT_OFF)<>SQL_SUCCESS Then Begin ErrorBox(LoadNLSStr(SErrSettingDBOpts)+'.'+ SQLErrorText(FDBProcs,FDBProcs.ahenv,0,0)); DoClose; Exit; End; {Connect} Try If FDBProcs.uid='' Then Begin If FDBProcs.pwd='' Then rc:=FDBProcs.SqlConnect(FDBProcs.ahdbc,FDBProcs.DataBase,SQL_NTS, Nil,0,Nil,0) Else rc:=FDBProcs.SqlConnect(FDBProcs.ahdbc,FDBProcs.DataBase,SQL_NTS, Nil,0,FDBProcs.pwd,SQL_NTS); End Else If FDBProcs.pwd='' Then Begin rc:=FDBProcs.SqlConnect(FDBProcs.ahdbc,FDBProcs.DataBase,SQL_NTS, FDBProcs.uid,SQL_NTS,Nil,0); End Else rc:= FDBProcs.SqlConnect(FDBProcs.ahdbc,FDBProcs.DataBase,SQL_NTS, FDBProcs.uid,SQL_NTS,FDBProcs.pwd,SQL_NTS); If rc<>SQL_SUCCESS Then Begin S:=SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,0); DoClose; SQLError(LoadNLSStr(SErrorDBConnecting)+' "'+DataBase+'".'+#13#10+S); End; Except ON E:ESQLError Do Begin ErrorBox(E.Message); Exit; End; Else Raise; End; FOpened:=True; If FAfterOpen<>Nil Then AfterOpen(Self); If FParams.Count=0 Then SetDefaultParams; Except Raise; End; End; End; Procedure TStoredProc.DoClose; Var OldOpened:Boolean; Begin Try If FBeforeClose<>Nil Then FBeforeClose(Self); OldOpened:=FOpened; TDataSet.DoClose; FOpened:=OldOpened; If FOpened Then Begin CloseStmt; Post; //Commit All transactions End; FActive:=False; FDataSetLocked:=True; FFieldDefs.Clear; FDataSetLocked:=False; If FDBProcs.ahdbc<>0 Then Begin If FOpened Then If FDBProcs.SQLDisconnect(FDBProcs.ahdbc)<>SQL_SUCCESS Then ErrorBox('Disconnect error '+SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,0)); If FDBProcs.SQLFreeConnect(FDBProcs.ahdbc)<>SQL_SUCCESS Then ErrorBox('FreeConnect error '+SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,0)); FDBProcs.ahdbc:=0; End; If FDBProcs.ahenv<>0 Then Begin If FDBProcs.SQLFreeEnv(FDBProcs.ahenv)<>SQL_SUCCESS Then ErrorBox('FreeEnv error '+SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,0)); FDBProcs.ahenv:=0; End; FOpened:=False; DataChange(deDataBaseChanged); If FAfterClose<>Nil Then FAfterClose(Self); Except Raise; End; End; Procedure TStoredProc.Loaded; Var OldOpen,OldActive:Boolean; Begin Inherited Loaded; OldOpen:=FOpened; OldActive:=FActive; FActive:=True; DoOpen; If not OldOpen Then DoClose; FActive:=OldActive; End; Procedure TStoredProc.Delete; Begin End; Procedure TStoredProc.Insert; Begin End; Procedure TStoredProc.InsertRecord(Const values:Array Of Const); Begin Try FDataChangeLock:=True; Insert; Finally FDataChangeLock:=False; End; SetFields(values); End; Function TStoredProc.UpdateFieldSelect(field:TField):Boolean; Begin Result:=False; End; Begin End.