UNIT VT_DEMO ; { -- automatisch von ER2SQL 3.38 erzeugte Unit fuer DELPHI 3.0+ (BDE). Erzeugungsdatum : Sat Jan 31 23:34:54 2004 Zieldatenbank (=BDE-Alias): DEMO Fuer die Virtabs werden 2 Objekte definiert: - ein Nachfahre von TTable ('TVirtabTableDEMO') - ein Nachfahre von TQuery ('TVirtabQueueDEMO') Die Query kann benutzt werden, wenn a) die SQL-property zur genutzt werden soll. Es wird bei Aenderung von VirtabKind geprueft, ob zumindest der Virtabname im SELECT-statement vorkommt. b) verhindert werden soll, dass die BDE die Virtab nach dem 'Open()' in ihre Puffer einliest. TVirtabTable bzw. TVirtabQueue besitzen folgende neue properties: - 'VirtabKind' waehlt die Art der vordefinierten Virtab aus ( kann auch erst zur Laufzeit angegeben werden). - 'VirtabSchema' sollte den Namen des ORACLE-Users enthalten, dem die VirTabs gehoeren. - Ist die globale Variable 'VirtabLogFile' <> '', so werden interne Aktionen in diese Datei protokolliert. Kann jederzeit geaendert werden. Die Namen der Prozedurparameter der INSERT/UPDATE/DELETE-Prozeduren werden aus den Spaltennamen gebildet, mit vorausgestelltem, konstantem Prefix 'ProcParm_Prefix' Dies erledigt die Function 'VT_ProcParmName(fieldname:string)'. Zum Einstellen diverser Konstanten auf die Zieldatenbank muss 'VT_SetDatabaseType(my_database.Session.GetAliasDriverType(my_database.Aliasname))' aufgerufen werden (my_database:TDatabase); und zwar als allererster Befehl. } INTERFACE uses SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, StdCtrls, Forms, Dialogs, DBCtrls, DB, DBGrids, Grids, ExtCtrls, DBTables ; CONST ProcParm_Prefix: string = 'p_' ; type { -- Aufzaehlungstyp mit allen definierten Virtabs } TVirtabKindDEMO = ( vtkNone, vtkSALES, vtkDEPTS, vtkDEPTS_2, vtkDEPTS_3, vtkDEPTS_4, vtkDEPTS_5, vtkDEPTS_6, vtkletter_data, vtkletter_data_emp, vtkletter_data_cust, vtkletter_data_main, vtkHIERARCHY, vtkDEPTSINFO, vtkDEPTSINFO1 ) ; type TVirtabTableDEMO = class(TTable) private setup_valid: boolean ; { sind die Prozeduren und Parameter noch gueltig? } fVirtabKind : TVirtabKindDEMO ; { welche Virtab ist es? } fVirtabSchema: string ; { der DB-besitzer der Virtab-Objekte } fVirtabName: string ; { Name der Virtab } { Userpointer der benutzten Dataset-Events } fBeforeOpen : TDatasetNotifyEvent ; fOnUpdateRecord: TUpdateRecordEvent ; fOnUpdateError: TUpdateErrorEvent ; fPersistentBookmark: TStringList ; { eigener Handler fuer BeforeOpen } procedure VTBeforeOpen(Dataset: TDataset) ; { eigener Handler fuer OnUpdateRecord } procedure VTOnUpdateRecord(Dataset: TDataset; UpdateKind: TUpdateKind; var UpdateAction: TUpdateAction) ; { eigener Handler fuer OnUpdateError } procedure VTOnUpdateError(Dataset: TDataset; E: EDatabaseError; UpdateKind: TUpdateKind; var UpdateAction: TUpdateAction) ; procedure SetKind(vk: TVirtabKindDEMO) ; { Art der Virtab aendern } procedure Setup ; { Setzt neue Prozeduren, Parameter, etc., wenn VirtabKind zur Laufzeit geaendert wird } function AddSchema(obj:string) : string ; { fuegt evtl. den Schemabezeichner vor einem DB-Objekt ein } function FieldIndexByName(fieldname:string):integer ; public constructor Create(AOwner: TComponent) ; override ; destructor Destroy ; override ; function IsPKField(fieldname:string): boolean ; function IsIdentField(fieldname:string): boolean ; function IsReadonlyField(fieldname:string): boolean ; function BookmarkFields : string ; procedure SetPersistentBookmark(bookmarkfields: string) ; procedure GotoPersistentBookmark ; function InsertProc : TStoredProc ; { Rueckgabe der Eintraege aus der globalen Procedure-Liste } function UpdateProc : TStoredProc ; function DeleteProc : TStoredProc ; published property VirtabKind: TVirtabKindDEMO read FVirtabKind write SetKind ; property VirtabName: string read FVirtabName ; property VirtabSchema: string read FVirtabSchema write FVirtabSchema ; property BeforeOpen: TDatasetNotifyEvent read FBeforeOpen write FBeforeOpen ; property OnUpdateRecord: TUpdateRecordEvent read FOnUpdateRecord write FOnUpdateRecord ; property OnUpdateError: TUpdateErrorEvent read FOnUpdateError write FOnUpdateError ; end ; TVirtabQueryDEMO = class(TQuery) private setup_valid: boolean ; { sind die Prozeduren und Parameter noch gueltig? } fVirtabKind : TVirtabKindDEMO ; { welche Virtab ist es? } fVirtabSchema: string ; { der DB-besitzer der Virtab-Objekte } fVirtabName: string ; { Name der Virtab } { Userpointer der benutzten Dataset-Events } fBeforeOpen : TDatasetNotifyEvent ; fOnUpdateRecord: TUpdateRecordEvent ; fOnUpdateError: TUpdateErrorEvent ; fPersistentBookmark: TStringList ; { eigener Handler fuer BeforeOpen } procedure VTBeforeOpen(Dataset: TDataset) ; { eigener Handler fuer OnUpdateRecord } procedure VTOnUpdateRecord(Dataset: TDataset; UpdateKind: TUpdateKind; var UpdateAction: TUpdateAction) ; { eigener Handler fuer OnUpdateError } procedure VTOnUpdateError(Dataset: TDataset; E: EDatabaseError; UpdateKind: TUpdateKind; var UpdateAction: TUpdateAction) ; procedure SetKind(vk: TVirtabKindDEMO) ; { Art der Virtab aendern } procedure Setup ; { Setzt neue Prozeduren, Parameter, etc., wenn VirtabKind zur Laufzeit geaendert wird } function AddSchema(obj:string) : string ; { fuegt evtl. den Schemabezeichner vor einem DB-Objekt ein } function FieldIndexByName(fieldname:string):integer ; { -- gibt den Index des Feldes in Fields zurueck; oder -1, wenn es nicht gefunden wurde } public constructor Create(AOwner: TComponent) ; override ; destructor Destroy ; override ; function IsPKField(fieldname:string): boolean ; function IsIdentField(fieldname:string): boolean ; function IsReadonlyField(fieldname:string): boolean ; procedure Refresh ; { eigenes Refresh } function BookmarkFields : string ; procedure SetPersistentBookmark(bookmarkfields: string) ; procedure GotoPersistentBookmark ; function InsertProc : TStoredProc ; { Rueckgabe der Eintraege aus der globalen Procedure-Liste } function UpdateProc : TStoredProc ; function DeleteProc : TStoredProc ; published property VirtabKind: TVirtabKindDEMO read FVirtabKind write SetKind ; property VirtabName: string read FVirtabName ; property VirtabSchema: string read FVirtabSchema write FVirtabSchema ; property BeforeOpen: TDatasetNotifyEvent read FBeforeOpen write FBeforeOpen ; property OnUpdateRecord: TUpdateRecordEvent read FOnUpdateRecord write FOnUpdateRecord ; property OnUpdateError: TUpdateErrorEvent read FOnUpdateError write FOnUpdateError ; end ; { globale Verwaltung aller stored procs } TProceduresDEMO = class(TObject) private Procedures: array[TVirtabKindDEMO,1..3] of TStoredProc ; { Zweiter Index: 1=Insert,2=Update,3=Delete } { --- Erzeugung der Virtab-Proceduren --- } procedure Setup_SALES_Proc(var Proc:TStoredProc; procname:string) ; procedure Setup_DEPTS_Proc(var Proc:TStoredProc; procname:string) ; procedure Setup_DEPTS_2_Proc(var Proc:TStoredProc; procname:string) ; procedure Setup_DEPTS_3_Proc(var Proc:TStoredProc; procname:string) ; procedure Setup_DEPTS_4_Proc(var Proc:TStoredProc; procname:string) ; procedure Setup_DEPTS_5_Proc(var Proc:TStoredProc; procname:string) ; procedure Setup_DEPTS_6_Proc(var Proc:TStoredProc; procname:string) ; procedure Setup_letter_data_Proc(var Proc:TStoredProc; procname:string) ; procedure Setup_letter_data_emp_Proc(var Proc:TStoredProc; procname:string) ; procedure Setup_letter_data_cust_Proc(var Proc:TStoredProc; procname:string) ; procedure Setup_letter_data_main_Proc(var Proc:TStoredProc; procname:string) ; procedure Setup_HIERARCHY_Proc(var Proc:TStoredProc; procname:string) ; procedure Setup_DEPTSINFO_Proc(var Proc:TStoredProc; procname:string) ; procedure Setup_DEPTSINFO1_Proc(var Proc:TStoredProc; procname:string) ; public constructor Create ; destructor Destroy ; override ; function GetProc(virtabkind: TVirtabKindDEMO; proctype:integer) : TStoredProc ; { Prozedur erzeugen, wenn sie noch nicht da ist } procedure CallProc(Proc: TStoredProc; Dataset: TDBDataset; use_old, read_back: boolean) ; { Procedur ausfuehren } end ; var VirtabLogFile : string ; ProceduresDEMO : TProceduresDEMO ; procedure Register ; function VTName2Kind(vtname:string; viewname: boolean): TVirtabKindDEMO ; { -- Gibt zu einem Virtabnamen die VirtabKind zurueck. Bei Fehler gibts 'vtkNone' Wenn 'viewname'=true: vtname mit Prefix 'vt_', sonst nur der Virtabname } function VTKind2Name(vtkind: TVirtabKindDEMO; viewname: boolean): string ; { -- Gibt zu einer VirtabKind den Virtabnamen zurueck. Bei Fehler gibts '' Wenn 'viewname'=true: Ergebnis mit Prefix 'vt_', sonst nur der Virtabname } procedure VT_SetDatabaseType(BDEdrivername:string) ; function VT_ProcParmName(fieldname:string): string ; procedure LogText(info : string ; zeilen : TStrings) ; procedure LogProc(info: string ; pr : TStoredProc) ; IMPLEMENTATION { -- fuer die Delphi-Komponentenpalette } procedure Register ; begin { Die Palettenseite 'DEMO' spaeter durch er2sql -dbname:DEMO setzen! } RegisterComponents('DEMO', [TVirtabTableDEMO,TVirtabQueryDEMO]) ; end ; procedure VT_SetDatabaseType(BDEdrivername:string) ; { -- der BDE-Drivername setzt die datenbankabhaengigen Konstanten } begin if Uppercase(BDEdrivername) = 'ORACLE' then begin ProcParm_Prefix := 'p_' ; end ; if Uppercase(BDEdrivername) = 'MSSQL' then begin ProcParm_Prefix := '@p_' ; end ; end ; function VTName2Kind(vtname:string; viewname: boolean): TVirtabKindDEMO ; { -- Gibt zu einem Virtabnamen die VirtabKind zurueck. Bei Fehler gibts 'vtkNone' Wenn 'viewname'=true: vtname mit Prefix 'vt_', sonst nur der Virtabname } begin result := vtkNone ; vtname := UpperCase(vtname) ; if not viewname then vtname := 'vt_'+vtname ; { intern wird immer mit dem Prefix gearbeitet } if vtname = 'vt_SALES' then result := vtkSALES ; if vtname = 'vt_DEPTS' then result := vtkDEPTS ; if vtname = 'vt_DEPTS_2' then result := vtkDEPTS_2 ; if vtname = 'vt_DEPTS_3' then result := vtkDEPTS_3 ; if vtname = 'vt_DEPTS_4' then result := vtkDEPTS_4 ; if vtname = 'vt_DEPTS_5' then result := vtkDEPTS_5 ; if vtname = 'vt_DEPTS_6' then result := vtkDEPTS_6 ; if vtname = 'vt_letter_data' then result := vtkletter_data ; if vtname = 'vt_letter_data_emp' then result := vtkletter_data_emp ; if vtname = 'vt_letter_data_cust' then result := vtkletter_data_cust ; if vtname = 'vt_letter_data_main' then result := vtkletter_data_main ; if vtname = 'vt_HIERARCHY' then result := vtkHIERARCHY ; if vtname = 'vt_DEPTSINFO' then result := vtkDEPTSINFO ; if vtname = 'vt_DEPTSINFO1' then result := vtkDEPTSINFO1 ; end ; function VTKind2Name(vtkind: TVirtabKindDEMO; viewname: boolean): string ; { -- Gibt zu einer VirtabKind den Virtabnamen zurueck. Bei Fehler gibts '' Wenn 'viewname'=true: Ergebnis mit Prefix 'vt_', sonst nur der Virtabname } var vtname: string ; begin vtname := '' ; if vtkind = vtkSALES then vtname := 'SALES' ; if vtkind = vtkDEPTS then vtname := 'DEPTS' ; if vtkind = vtkDEPTS_2 then vtname := 'DEPTS_2' ; if vtkind = vtkDEPTS_3 then vtname := 'DEPTS_3' ; if vtkind = vtkDEPTS_4 then vtname := 'DEPTS_4' ; if vtkind = vtkDEPTS_5 then vtname := 'DEPTS_5' ; if vtkind = vtkDEPTS_6 then vtname := 'DEPTS_6' ; if vtkind = vtkLETTER_DATA then vtname := 'letter_data' ; if vtkind = vtkLETTER_DATA_EMP then vtname := 'letter_data_emp' ; if vtkind = vtkLETTER_DATA_CUST then vtname := 'letter_data_cust' ; if vtkind = vtkLETTER_DATA_MAIN then vtname := 'letter_data_main' ; if vtkind = vtkHIERARCHY then vtname := 'HIERARCHY' ; if vtkind = vtkDEPTSINFO then vtname := 'DEPTSINFO' ; if vtkind = vtkDEPTSINFO1 then vtname := 'DEPTSINFO1' ; if (vtname <> '') and viewname then vtname := 'vt_'+vtname ; result := vtname ; end ; { -- Zeilen in den Logfile, wenn 'VirtabLogfile' gesetzt ist. } procedure LogText(info : string ; zeilen : TStrings) ; var i: integer ; f: system.text ; begin if VirtabLogFile <> '' then begin system.assign(f, VirtabLogFile) ; try system.append(f) except system.rewrite(f) end ; writeln(f, '--------- ', DateTimeToStr(Now), ' -------') ; writeln(f, 'Info: ', info) ; writeln(f) ; if zeilen <> nil then for i := 0 to zeilen.Count-1 do writeln(f, '[', i:2, '] ', zeilen.Strings[i]) ; writeln(f) ; system.close(f) ; end ; end ; { -- Parameter einer StoredProc loggen } procedure LogProc(info: string ; pr : TStoredProc) ; var i : integer ; l : TStringList ; begin l := TStringList.Create ; for i := 0 to pr.Params.Count-1 do with pr.Params.Items[i] do if IsNull then l.Add(Format('%s=NULL', [Name])) else l.Add(Format('%s="%s"', [Name, AsString])) ; LogText(info+' Parameter von Proc "'+pr.StoredProcName+'" =', l) ; l.Free ; end ; function VT_ProcParmName(fieldname:string): string ; begin result := ProcParm_Prefix + fieldname ; { kein Uppercase } end ; function FieldType2Text(datatype : TFieldType) : string ; begin case datatype of ftUnknown : FieldType2Text := 'ftUnknown' ; ftString : FieldType2Text := 'ftString' ; ftSmallint: FieldType2Text := 'ftSmallint' ; ftInteger : FieldType2Text := 'ftInteger' ; ftWord : FieldType2Text := 'ftWord' ; ftBoolean : FieldType2Text := 'ftBoolean' ; ftFloat : FieldType2Text := 'ftFloat' ; ftCurrency: FieldType2Text := 'ftCurrency' ; ftBCD : FieldType2Text := 'ftBCD' ; ftDate : FieldType2Text := 'ftDate' ; ftTime : FieldType2Text := 'ftTime' ; ftDateTime: FieldType2Text := 'ftDateTime' ; ftBytes : FieldType2Text := 'ftBytes' ; ftVarBytes: FieldType2Text := 'ftVarBytes' ; ftBlob : FieldType2Text := 'ftBlob' ; ftMemo : FieldType2Text := 'ftMemo' ; ftGraphic : FieldType2Text := 'ftGraphic' ; else FieldType2Text := 'UNKNOWN' ; end ; end ; (* procedure ShowProc(proc : TStoredProc) ; { -- Diagnoseausgabe der Parameterbelegung } var i : word ; begin with proc do begin writeln('Parameter der Procedure ', proc.StoredProcname) ; for i := 0 to ParamCount-1 do with Params[i] do begin writeln(Name, ': ', FieldType2text(DataType)) ; writeln(' = ', AsString) ; end ; end ; end ; *) constructor TProceduresDEMO.Create ; var vtkind: TVirtabKindDEMO ; proctype: integer ; begin inherited ; for vtkind := low(TVirtabKindDEMO) to high(TVirtabKindDEMO) do for proctype := 1 to 3 do Procedures[vtkind,proctype] := nil ; end ; destructor TProceduresDEMO.Destroy ; var vtkind: TVirtabKindDEMO ; proctype: integer ; begin for vtkind := low(TVirtabKindDEMO) to high(TVirtabKindDEMO) do for proctype := 1 to 3 do if Procedures[vtkind,proctype] <> nil then begin Procedures[vtkind,proctype].Free ; Procedures[vtkind,proctype] := nil ; end ; inherited ; end ; function TProceduresDEMO.GetProc(virtabkind: TVirtabKindDEMO; proctype:integer) : TStoredProc ; { Gibt Procedur zurueck, erzeugt sie ggf. erst } var proc: TStoredProc ; begin proc := Procedures[virtabkind,proctype] ; if proc = nil then begin proc := TStoredProc.Create(nil) ; Procedures[virtabkind,proctype] := proc ; case proctype of 1: { eine Insert-Prozedur anlegen } case virtabkind of vtkSALES: Setup_SALES_Proc(proc, 'pi_SALES') ; vtkDEPTS: Setup_DEPTS_Proc(proc, 'pi_DEPTS') ; vtkDEPTS_2: Setup_DEPTS_2_Proc(proc, 'pi_DEPTS_2') ; vtkDEPTS_3: Setup_DEPTS_3_Proc(proc, 'pi_DEPTS_3') ; vtkDEPTS_4: Setup_DEPTS_4_Proc(proc, 'pi_DEPTS_4') ; vtkDEPTS_5: Setup_DEPTS_5_Proc(proc, 'pi_DEPTS_5') ; vtkDEPTS_6: Setup_DEPTS_6_Proc(proc, 'pi_DEPTS_6') ; vtkletter_data: Setup_LETTER_DATA_Proc(proc, 'pi_letter_data') ; vtkletter_data_emp: Setup_LETTER_DATA_EMP_Proc(proc, 'pi_letter_data_emp') ; vtkletter_data_cust: Setup_LETTER_DATA_CUST_Proc(proc, 'pi_letter_data_cust') ; vtkletter_data_main: Setup_LETTER_DATA_MAIN_Proc(proc, 'pi_letter_data_main') ; vtkHIERARCHY: Setup_HIERARCHY_Proc(proc, 'pi_HIERARCHY') ; vtkDEPTSINFO: Setup_DEPTSINFO_Proc(proc, 'pi_DEPTSINFO') ; vtkDEPTSINFO1: Setup_DEPTSINFO1_Proc(proc, 'pi_DEPTSINFO1') ; end { case FVirtabKind } ; { end case proctype of 1 / InsertProc } 2: { eine Update-Prozedur anlegen } case virtabkind of vtkSALES: Setup_SALES_Proc(proc, 'pu_SALES') ; vtkDEPTS: Setup_DEPTS_Proc(proc, 'pu_DEPTS') ; vtkDEPTS_2: Setup_DEPTS_2_Proc(proc, 'pu_DEPTS_2') ; vtkDEPTS_3: Setup_DEPTS_3_Proc(proc, 'pu_DEPTS_3') ; vtkDEPTS_4: Setup_DEPTS_4_Proc(proc, 'pu_DEPTS_4') ; vtkDEPTS_5: Setup_DEPTS_5_Proc(proc, 'pu_DEPTS_5') ; vtkDEPTS_6: Setup_DEPTS_6_Proc(proc, 'pu_DEPTS_6') ; vtkletter_data: Setup_LETTER_DATA_Proc(proc, 'pu_letter_data') ; vtkletter_data_emp: Setup_LETTER_DATA_EMP_Proc(proc, 'pu_letter_data_emp') ; vtkletter_data_cust: Setup_LETTER_DATA_CUST_Proc(proc, 'pu_letter_data_cust') ; vtkletter_data_main: Setup_LETTER_DATA_MAIN_Proc(proc, 'pu_letter_data_main') ; vtkHIERARCHY: Setup_HIERARCHY_Proc(proc, 'pu_HIERARCHY') ; vtkDEPTSINFO: Setup_DEPTSINFO_Proc(proc, 'pu_DEPTSINFO') ; vtkDEPTSINFO1: Setup_DEPTSINFO1_Proc(proc, 'pu_DEPTSINFO1') ; end { case FVirtabKind } ; { end case proctype of 2 / UpdateProc } 3: { eine Delete-Prozedur anlegen } case virtabkind of vtkSALES: Setup_SALES_Proc(proc, 'pd_SALES') ; vtkDEPTS: Setup_DEPTS_Proc(proc, 'pd_DEPTS') ; vtkDEPTS_2: Setup_DEPTS_2_Proc(proc, 'pd_DEPTS_2') ; vtkDEPTS_3: Setup_DEPTS_3_Proc(proc, 'pd_DEPTS_3') ; vtkDEPTS_4: Setup_DEPTS_4_Proc(proc, 'pd_DEPTS_4') ; vtkDEPTS_5: Setup_DEPTS_5_Proc(proc, 'pd_DEPTS_5') ; vtkDEPTS_6: Setup_DEPTS_6_Proc(proc, 'pd_DEPTS_6') ; vtkletter_data: Setup_LETTER_DATA_Proc(proc, 'pd_letter_data') ; vtkletter_data_emp: Setup_LETTER_DATA_EMP_Proc(proc, 'pd_letter_data_emp') ; vtkletter_data_cust: Setup_LETTER_DATA_CUST_Proc(proc, 'pd_letter_data_cust') ; vtkletter_data_main: Setup_LETTER_DATA_MAIN_Proc(proc, 'pd_letter_data_main') ; vtkHIERARCHY: Setup_HIERARCHY_Proc(proc, 'pd_HIERARCHY') ; vtkDEPTSINFO: Setup_DEPTSINFO_Proc(proc, 'pd_DEPTSINFO') ; vtkDEPTSINFO1: Setup_DEPTSINFO1_Proc(proc, 'pd_DEPTSINFO1') ; end { case FVirtabKind } ; { end case proctype of 3 / DeleteProc } end { case proctype } ; end { if proc = nil } ; result := proc ; end ; procedure TProceduresDEMO.CallProc(Proc: TStoredProc ; Dataset: TDBDataset; use_old, read_back: boolean) ; { -- fuellt Proc.Params aus Dataset.Fields und startet Proc 'use_old'= false: neue Feldwerte fuer InsertProc und UpdateProc 'use_old'= true: alte Feldwerte fuer DeleteProc. 'read_back'= true: neue Feldwerte mit geaenderten Prozedurparameter aktualisieren. Fehler, wenn leere Parameterliste: dann proc fuer NOCHANGE-Virtab. } var i : word ; f : TField ; p : TParam ; v : variant ; begin if (Proc = nil) or (Proc.ParamCount = 0) then raise Exception.Create('Procedur nicht definiert; Virtabs ist NOCHANGE') ; if not Proc.Prepared then begin Proc.Databasename := Dataset.Databasename ; Proc.SessionName := Dataset.SessionName ; Proc.Prepare ; end ; for i := 0 to Dataset.FieldCount-1 do begin f := Dataset.Fields[i] ; if f.FieldKind = fkData then begin p := Proc.ParamByName(VT_ProcParmName(f.FieldName)) ; if use_old then v := f.oldvalue else v := f.newvalue ; if vartype(v) = varNull then p.Clear { ist NULL } else p.value := v ; { writeln(f.FieldName, ': ', '(', FieldType2Text(f.DataType), ') ', f.AsString, ' -> (', FieldType2Text(p.DataType),') ', p.AsString, '.');} end ; end ; LogProc('', Proc) ; Proc.ExecProc ; if read_back then { Procparameter nach DS rueckschreiben } for i := 0 to Dataset.FieldCount-1 do begin f := Dataset.Fields[i] ; if (not f.readonly) and (f.FieldKind = fkData) then begin p := Proc.ParamByName(VT_ProcParmName(f.fieldname)) ; v := p.Value ; f.newvalue := v ; { egal ob NULL}; end ; end ; end ; procedure TProceduresDEMO.Setup_SALES_Proc(var proc:TStoredProc; procname:string) ; begin if proc = nil then raise Exception.Create('Ungueltige proc in Setup_SALES_Proc() uebergeben') ; with proc do begin AutoCalcFields := true ; // DataBaseName := dbname ; passiert erst direkt vor Aufruf Overload := 0 ; ParamBindMode := pbByName ; StoredProcName := procname ; Tag := 0; Params.CreateParam(ftFloat,VT_ProcParmName('SALESPERSON_ID'),ptInputOutput) ; Params.CreateParam(ftFloat,VT_ProcParmName('CUSTOMER_ID'),ptInputOutput) ; Params.CreateParam(ftString,VT_ProcParmName('CUSTOMER'),ptInputOutput) ; Params.CreateParam(ftFloat,VT_ProcParmName('PRODUCT_ID'),ptInputOutput) ; Params.CreateParam(ftString,VT_ProcParmName('PRODUCT'),ptInputOutput) ; end ; end ; procedure TProceduresDEMO.Setup_DEPTS_Proc(var proc:TStoredProc; procname:string) ; begin if proc = nil then raise Exception.Create('Ungueltige proc in Setup_DEPTS_Proc() uebergeben') ; with proc do begin AutoCalcFields := true ; // DataBaseName := dbname ; passiert erst direkt vor Aufruf Overload := 0 ; ParamBindMode := pbByName ; StoredProcName := procname ; Tag := 0; Params.CreateParam(ftString,VT_ProcParmName('REGIONAL_GROUP'),ptInputOutput) ; Params.CreateParam(ftString,VT_ProcParmName('DEPARTMENT_NAME'),ptInputOutput) ; Params.CreateParam(ftString,VT_ProcParmName('street'),ptInputOutput) ; Params.CreateParam(ftString,VT_ProcParmName('CITY'),ptInputOutput) ; Params.CreateParam(ftString,VT_ProcParmName('STATE'),ptInputOutput) ; Params.CreateParam(ftString,VT_ProcParmName('ZIP_CODE'),ptInputOutput) ; end ; end ; procedure TProceduresDEMO.Setup_DEPTS_2_Proc(var proc:TStoredProc; procname:string) ; begin if proc = nil then raise Exception.Create('Ungueltige proc in Setup_DEPTS_2_Proc() uebergeben') ; with proc do begin AutoCalcFields := true ; // DataBaseName := dbname ; passiert erst direkt vor Aufruf Overload := 0 ; ParamBindMode := pbByName ; StoredProcName := procname ; Tag := 0; Params.CreateParam(ftString,VT_ProcParmName('REGIONAL_GROUP'),ptInputOutput) ; Params.CreateParam(ftString,VT_ProcParmName('DEPARTMENT'),ptInputOutput) ; Params.CreateParam(ftString,VT_ProcParmName('street'),ptInputOutput) ; Params.CreateParam(ftString,VT_ProcParmName('CITY'),ptInputOutput) ; Params.CreateParam(ftString,VT_ProcParmName('STATE'),ptInputOutput) ; Params.CreateParam(ftString,VT_ProcParmName('ZIP_CODE'),ptInputOutput) ; end ; end ; procedure TProceduresDEMO.Setup_DEPTS_3_Proc(var proc:TStoredProc; procname:string) ; begin if proc = nil then raise Exception.Create('Ungueltige proc in Setup_DEPTS_3_Proc() uebergeben') ; with proc do begin AutoCalcFields := true ; // DataBaseName := dbname ; passiert erst direkt vor Aufruf Overload := 0 ; ParamBindMode := pbByName ; StoredProcName := procname ; Tag := 0; Params.CreateParam(ftString,VT_ProcParmName('REGIONAL_GROUP'),ptInputOutput) ; Params.CreateParam(ftString,VT_ProcParmName('DEPARTMENT'),ptInputOutput) ; Params.CreateParam(ftString,VT_ProcParmName('street'),ptInputOutput) ; Params.CreateParam(ftString,VT_ProcParmName('CITY'),ptInputOutput) ; Params.CreateParam(ftString,VT_ProcParmName('STATE'),ptInputOutput) ; Params.CreateParam(ftString,VT_ProcParmName('ZIP_CODE'),ptInputOutput) ; end ; end ; procedure TProceduresDEMO.Setup_DEPTS_4_Proc(var proc:TStoredProc; procname:string) ; begin if proc = nil then raise Exception.Create('Ungueltige proc in Setup_DEPTS_4_Proc() uebergeben') ; with proc do begin AutoCalcFields := true ; // DataBaseName := dbname ; passiert erst direkt vor Aufruf Overload := 0 ; ParamBindMode := pbByName ; StoredProcName := procname ; Tag := 0; Params.CreateParam(ftString,VT_ProcParmName('REGIONAL_GROUP'),ptInputOutput) ; Params.CreateParam(ftString,VT_ProcParmName('DEPARTMENT'),ptInputOutput) ; end ; end ; procedure TProceduresDEMO.Setup_DEPTS_5_Proc(var proc:TStoredProc; procname:string) ; begin if proc = nil then raise Exception.Create('Ungueltige proc in Setup_DEPTS_5_Proc() uebergeben') ; with proc do begin AutoCalcFields := true ; // DataBaseName := dbname ; passiert erst direkt vor Aufruf Overload := 0 ; ParamBindMode := pbByName ; StoredProcName := procname ; Tag := 0; Params.CreateParam(ftString,VT_ProcParmName('REGIONAL_GROUP'),ptInputOutput) ; Params.CreateParam(ftString,VT_ProcParmName('DEPARTMENT'),ptInputOutput) ; Params.CreateParam(ftString,VT_ProcParmName('street'),ptInputOutput) ; Params.CreateParam(ftString,VT_ProcParmName('CITY'),ptInputOutput) ; Params.CreateParam(ftString,VT_ProcParmName('STATE'),ptInputOutput) ; Params.CreateParam(ftString,VT_ProcParmName('ZIP_CODE'),ptInputOutput) ; end ; end ; procedure TProceduresDEMO.Setup_DEPTS_6_Proc(var proc:TStoredProc; procname:string) ; begin if proc = nil then raise Exception.Create('Ungueltige proc in Setup_DEPTS_6_Proc() uebergeben') ; with proc do begin AutoCalcFields := true ; // DataBaseName := dbname ; passiert erst direkt vor Aufruf Overload := 0 ; ParamBindMode := pbByName ; StoredProcName := procname ; Tag := 0; Params.CreateParam(ftString,VT_ProcParmName('DEPARTMENT'),ptInputOutput) ; Params.CreateParam(ftString,VT_ProcParmName('street'),ptInputOutput) ; Params.CreateParam(ftString,VT_ProcParmName('CITY'),ptInputOutput) ; Params.CreateParam(ftString,VT_ProcParmName('STATE'),ptInputOutput) ; Params.CreateParam(ftString,VT_ProcParmName('ZIP_CODE'),ptInputOutput) ; end ; end ; procedure TProceduresDEMO.Setup_LETTER_DATA_Proc(var proc:TStoredProc; procname:string) ; begin if proc = nil then raise Exception.Create('Ungueltige proc in Setup_LETTER_DATA_Proc() uebergeben') ; with proc do begin AutoCalcFields := true ; // DataBaseName := dbname ; passiert erst direkt vor Aufruf Overload := 0 ; ParamBindMode := pbByName ; StoredProcName := procname ; Tag := 0; Params.CreateParam(ftString,VT_ProcParmName('emp_first_name'),ptInputOutput) ; Params.CreateParam(ftString,VT_ProcParmName('emp_last_name'),ptInputOutput) ; Params.CreateParam(ftString,VT_ProcParmName('emp_street'),ptInputOutput) ; Params.CreateParam(ftString,VT_ProcParmName('emp_city'),ptInputOutput) ; Params.CreateParam(ftString,VT_ProcParmName('emp_state'),ptInputOutput) ; Params.CreateParam(ftString,VT_ProcParmName('emp_zip_code'),ptInputOutput) ; Params.CreateParam(ftString,VT_ProcParmName('emp_department'),ptInputOutput) ; Params.CreateParam(ftString,VT_ProcParmName('emp_loc'),ptInputOutput) ; Params.CreateParam(ftString,VT_ProcParmName('cust_name'),ptInputOutput) ; Params.CreateParam(ftString,VT_ProcParmName('cust_street'),ptInputOutput) ; Params.CreateParam(ftString,VT_ProcParmName('cust_city'),ptInputOutput) ; Params.CreateParam(ftString,VT_ProcParmName('cust_state'),ptInputOutput) ; Params.CreateParam(ftString,VT_ProcParmName('cust_zip_code'),ptInputOutput) ; end ; end ; procedure TProceduresDEMO.Setup_LETTER_DATA_EMP_Proc(var proc:TStoredProc; procname:string) ; begin if proc = nil then raise Exception.Create('Ungueltige proc in Setup_LETTER_DATA_EMP_Proc() uebergeben') ; with proc do begin AutoCalcFields := true ; // DataBaseName := dbname ; passiert erst direkt vor Aufruf Overload := 0 ; ParamBindMode := pbByName ; StoredProcName := procname ; Tag := 0; { Virtab ist NOCHANGE: keine Parameter definieren ... } end ; end ; procedure TProceduresDEMO.Setup_LETTER_DATA_CUST_Proc(var proc:TStoredProc; procname:string) ; begin if proc = nil then raise Exception.Create('Ungueltige proc in Setup_LETTER_DATA_CUST_Proc() uebergeben') ; with proc do begin AutoCalcFields := true ; // DataBaseName := dbname ; passiert erst direkt vor Aufruf Overload := 0 ; ParamBindMode := pbByName ; StoredProcName := procname ; Tag := 0; { Virtab ist NOCHANGE: keine Parameter definieren ... } end ; end ; procedure TProceduresDEMO.Setup_LETTER_DATA_MAIN_Proc(var proc:TStoredProc; procname:string) ; begin if proc = nil then raise Exception.Create('Ungueltige proc in Setup_LETTER_DATA_MAIN_Proc() uebergeben') ; with proc do begin AutoCalcFields := true ; // DataBaseName := dbname ; passiert erst direkt vor Aufruf Overload := 0 ; ParamBindMode := pbByName ; StoredProcName := procname ; Tag := 0; { Virtab ist NOCHANGE: keine Parameter definieren ... } end ; end ; procedure TProceduresDEMO.Setup_HIERARCHY_Proc(var proc:TStoredProc; procname:string) ; begin if proc = nil then raise Exception.Create('Ungueltige proc in Setup_HIERARCHY_Proc() uebergeben') ; with proc do begin AutoCalcFields := true ; // DataBaseName := dbname ; passiert erst direkt vor Aufruf Overload := 0 ; ParamBindMode := pbByName ; StoredProcName := procname ; Tag := 0; Params.CreateParam(ftString,VT_ProcParmName('boss'),ptInputOutput) ; Params.CreateParam(ftString,VT_ProcParmName('boss_job'),ptInputOutput) ; Params.CreateParam(ftString,VT_ProcParmName('slave'),ptInputOutput) ; Params.CreateParam(ftString,VT_ProcParmName('slave_job'),ptInputOutput) ; Params.CreateParam(ftString,VT_ProcParmName('slave_loc'),ptInputOutput) ; Params.CreateParam(ftString,VT_ProcParmName('slave_dept'),ptInputOutput) ; end ; end ; procedure TProceduresDEMO.Setup_DEPTSINFO_Proc(var proc:TStoredProc; procname:string) ; begin if proc = nil then raise Exception.Create('Ungueltige proc in Setup_DEPTSINFO_Proc() uebergeben') ; with proc do begin AutoCalcFields := true ; // DataBaseName := dbname ; passiert erst direkt vor Aufruf Overload := 0 ; ParamBindMode := pbByName ; StoredProcName := procname ; Tag := 0; Params.CreateParam(ftString,VT_ProcParmName('REGIONAL_GROUP'),ptInputOutput) ; Params.CreateParam(ftString,VT_ProcParmName('DEPARTMENT_NAME'),ptInputOutput) ; Params.CreateParam(ftString,VT_ProcParmName('street'),ptInputOutput) ; Params.CreateParam(ftString,VT_ProcParmName('CITY'),ptInputOutput) ; Params.CreateParam(ftString,VT_ProcParmName('STATE'),ptInputOutput) ; Params.CreateParam(ftString,VT_ProcParmName('ZIP_CODE'),ptInputOutput) ; Params.CreateParam(ftString,VT_ProcParmName('DEPT_PER_LOC'),ptInputOutput) ; end ; end ; procedure TProceduresDEMO.Setup_DEPTSINFO1_Proc(var proc:TStoredProc; procname:string) ; begin if proc = nil then raise Exception.Create('Ungueltige proc in Setup_DEPTSINFO1_Proc() uebergeben') ; with proc do begin AutoCalcFields := true ; // DataBaseName := dbname ; passiert erst direkt vor Aufruf Overload := 0 ; ParamBindMode := pbByName ; StoredProcName := procname ; Tag := 0; Params.CreateParam(ftString,VT_ProcParmName('REGIONAL_GROUP'),ptInputOutput) ; Params.CreateParam(ftString,VT_ProcParmName('DEPARTMENT_NAME'),ptInputOutput) ; Params.CreateParam(ftString,VT_ProcParmName('street'),ptInputOutput) ; Params.CreateParam(ftString,VT_ProcParmName('CITY'),ptInputOutput) ; Params.CreateParam(ftString,VT_ProcParmName('STATE'),ptInputOutput) ; Params.CreateParam(ftString,VT_ProcParmName('ZIP_CODE'),ptInputOutput) ; Params.CreateParam(ftString,VT_ProcParmName('LOC_PER_DEPT'),ptInputOutput) ; end ; end ; function _IsPKField(FVirtabKind: TVirtabKindDEMO; fieldname:string): boolean ; begin result := false ; fieldname := UpperCase(fieldname) ; case FVirtabKind of vtkSALES: if (fieldname = 'SALESPERSON_ID') or (fieldname = 'CUSTOMER_ID') or (fieldname = 'PRODUCT_ID') then result := true ; vtkDEPTS: result := false ; vtkDEPTS_2: result := false ; vtkDEPTS_3: result := false ; vtkDEPTS_4: result := false ; vtkDEPTS_5: result := false ; vtkDEPTS_6: result := false ; vtkletter_data: result := false ; vtkletter_data_emp: result := false ; vtkletter_data_cust: result := false ; vtkletter_data_main: result := false ; vtkHIERARCHY: result := false ; vtkDEPTSINFO: result := false ; vtkDEPTSINFO1: result := false ; end { "case" } ; end ; function _IsIdentField(FVirtabKind: TVirtabKindDEMO; fieldname:string): boolean ; begin result := false ; fieldname := UpperCase(fieldname) ; case FVirtabKind of vtkSALES: if (fieldname = 'CUSTOMER') then result := true ; vtkDEPTS: if (fieldname = 'REGIONAL_GROUP') or (fieldname = 'DEPARTMENT_NAME') then result := true ; vtkDEPTS_2: if (fieldname = 'REGIONAL_GROUP') or (fieldname = 'DEPARTMENT') then result := true ; vtkDEPTS_3: if (fieldname = 'REGIONAL_GROUP') or (fieldname = 'DEPARTMENT') then result := true ; vtkDEPTS_4: if (fieldname = 'REGIONAL_GROUP') or (fieldname = 'DEPARTMENT') then result := true ; vtkDEPTS_5: if (fieldname = 'REGIONAL_GROUP') or (fieldname = 'DEPARTMENT') then result := true ; vtkDEPTS_6: if (fieldname = 'DEPARTMENT') then result := true ; vtkletter_data: if (fieldname = 'EMP_FIRST_NAME') or (fieldname = 'EMP_LAST_NAME') or (fieldname = 'EMP_DEPARTMENT') or (fieldname = 'EMP_LOC') or (fieldname = 'CUST_NAME') then result := true ; vtkletter_data_emp: if (fieldname = 'EMP_FIRST_NAME') or (fieldname = 'EMP_LAST_NAME') or (fieldname = 'EMP_DEPARTMENT') or (fieldname = 'EMP_LOC') then result := true ; vtkletter_data_cust: if (fieldname = 'CUST_NAME') then result := true ; vtkletter_data_main: if (fieldname = 'EMP_FIRST_NAME') or (fieldname = 'EMP_LAST_NAME') or (fieldname = 'CUST_NAME') then result := true ; vtkHIERARCHY: if (fieldname = 'BOSS') or (fieldname = 'BOSS_JOB') or (fieldname = 'SLAVE') or (fieldname = 'SLAVE_JOB') or (fieldname = 'SLAVE_LOC') or (fieldname = 'SLAVE_DEPT') then result := true ; vtkDEPTSINFO: if (fieldname = 'REGIONAL_GROUP') or (fieldname = 'DEPARTMENT_NAME') then result := true ; vtkDEPTSINFO1: if (fieldname = 'REGIONAL_GROUP') or (fieldname = 'DEPARTMENT_NAME') then result := true ; end { "case" } ; end ; function _IsReadonlyField(FVirtabKind: TVirtabKindDEMO; fieldname:string): boolean ; begin result := false ; fieldname := UpperCase(fieldname) ; case FVirtabKind of vtkSALES: if (fieldname = 'SALESPERSON_ID') or (fieldname = 'CUSTOMER_ID') or (fieldname = 'CUSTOMER') then result := true ; vtkDEPTS: result := false ; vtkDEPTS_2: if (fieldname = 'REGIONAL_GROUP') then result := true ; vtkDEPTS_3: if (fieldname = 'REGIONAL_GROUP') then result := true ; vtkDEPTS_4: if (fieldname = 'REGIONAL_GROUP') then result := true ; vtkDEPTS_5: if (fieldname = 'REGIONAL_GROUP') then result := true ; vtkDEPTS_6: result := false ; vtkletter_data: if (fieldname = 'EMP_FIRST_NAME') or (fieldname = 'EMP_LAST_NAME') or (fieldname = 'EMP_STREET') or (fieldname = 'EMP_CITY') or (fieldname = 'EMP_STATE') or (fieldname = 'EMP_ZIP_CODE') or (fieldname = 'EMP_DEPARTMENT') or (fieldname = 'EMP_LOC') then result := true ; vtkletter_data_emp: result := true ; { die ganze VT ist NOCHANGE } vtkletter_data_cust: result := true ; { die ganze VT ist NOCHANGE } vtkletter_data_main: result := true ; { die ganze VT ist NOCHANGE } vtkHIERARCHY: if (fieldname = 'BOSS') or (fieldname = 'BOSS_JOB') or (fieldname = 'SLAVE_JOB') or (fieldname = 'SLAVE_LOC') or (fieldname = 'SLAVE_DEPT') then result := true ; vtkDEPTSINFO: result := false ; vtkDEPTSINFO1: result := false ; end { "case" } ; end ; { ------- Table-Objekt fuer alle VirTabs ----------------------- } constructor TVirtabTableDEMO.Create(AOwner:TComponent) ; begin inherited Create(AOwner) ; setup_valid := true ; FVirtabKind := vtkNone ; { Virtab ist noch von keiner Art } FVirtabName := '' ; FVirtabSchema := 'vtdemo' ; { aus 'er2sql -dbschema:vtdemo'} { DatabaseName := 'DEMO' ; { Nicht schon in Create, sonst Probleme } AutoCalcFields := true ; Exclusive := false ; ReadOnly := false ; CachedUpdates := true ; { nicht veraendern !!! } TableType := ttDefault ; Tag := 0 ; fPersistentBookmark := nil ; { Sperrung moeglichst wenig restriktiv, da Aenderungen per PROC-Calls aus BDE-Sicht auch von anderen Applikationen kommen } UpdateMode := upWhereKeyOnly ; inherited BeforeOpen := VTBeforeOpen ; inherited OnUpdateRecord := VTOnUpdateRecord ; inherited OnUpdateError := VTOnUpdateError ; end ; destructor TVirtabTableDEMO.Destroy ; begin if fPersistentBookmark <> nil then fPersistentBookmark.Free ; fPersistentBookmark := nil ; inherited Destroy ; end ; { Abwaertskompatibler Zugriff auf die Stored procs } function TVirtabTableDEMO.InsertProc : TStoredProc ; { Rueckgabe der Eintraege aus der globalen procedure-Liste } begin result := ProceduresDEMO.GetProc(fVirtabKind, 1 {=insert}) ; end ; function TVirtabTableDEMO.UpdateProc : TStoredProc ; begin result := ProceduresDEMO.GetProc(fVirtabKind, 2 {=update}) ; end ; function TVirtabTableDEMO.DeleteProc : TStoredProc ; begin result := ProceduresDEMO.GetProc(fVirtabKind, 3 {=delete}) ; end ; function TVirtabTableDEMO.AddSchema(obj: string) : string ; { -- fuegt evtl. den Schemabezeichner vor einem DB-Objekt ein } begin if FVirtabSchema = '' then AddSchema := obj else AddSchema := FVirtabSchema + '.' + obj ; end ; function TVirtabTableDEMO.FieldIndexByName(fieldname:string):integer ; { -- gibt den Index des Feldes in Fields zurueck; oder -1, wenn es nicht gefunden wurde } var f: TField ; begin f := FindField(fieldname) ; if f = nil then result := -1 else result := f.Index ; end ; procedure TVirtabTableDEMO.SetKind(vk: TVirtabKindDEMO) ; { -- Wenn die Art der Virtab geaendert wird, muessen * zur Designzeit der Name * zur Laufzeit alle Einstellungen neu gesetzt werden. } begin if FVirtabKind <> vk then begin { nur bei wirklichen Aenderungen was tun } { Loesche alte Prozeduren } FVirtabKind := vk ; case FVirtabKind of vtkSALES: begin FVirtabName := 'SALES' ; TableName := UpperCase('vt_SALES') ; end ; vtkDEPTS: begin FVirtabName := 'DEPTS' ; TableName := UpperCase('vt_DEPTS') ; end ; vtkDEPTS_2: begin FVirtabName := 'DEPTS_2' ; TableName := UpperCase('vt_DEPTS_2') ; end ; vtkDEPTS_3: begin FVirtabName := 'DEPTS_3' ; TableName := UpperCase('vt_DEPTS_3') ; end ; vtkDEPTS_4: begin FVirtabName := 'DEPTS_4' ; TableName := UpperCase('vt_DEPTS_4') ; end ; vtkDEPTS_5: begin FVirtabName := 'DEPTS_5' ; TableName := UpperCase('vt_DEPTS_5') ; end ; vtkDEPTS_6: begin FVirtabName := 'DEPTS_6' ; TableName := UpperCase('vt_DEPTS_6') ; end ; vtkletter_data: begin FVirtabName := 'letter_data' ; TableName := UpperCase('vt_letter_data') ; end ; vtkletter_data_emp: begin FVirtabName := 'letter_data_emp' ; TableName := UpperCase('vt_letter_data_emp') ; end ; vtkletter_data_cust: begin FVirtabName := 'letter_data_cust' ; TableName := UpperCase('vt_letter_data_cust') ; end ; vtkletter_data_main: begin FVirtabName := 'letter_data_main' ; TableName := UpperCase('vt_letter_data_main') ; end ; vtkHIERARCHY: begin FVirtabName := 'HIERARCHY' ; TableName := UpperCase('vt_HIERARCHY') ; end ; vtkDEPTSINFO: begin FVirtabName := 'DEPTSINFO' ; TableName := UpperCase('vt_DEPTSINFO') ; end ; vtkDEPTSINFO1: begin FVirtabName := 'DEPTSINFO1' ; TableName := UpperCase('vt_DEPTSINFO1') ; end ; else begin FVirtabName := '' ; TableName := '' ; end ; end { "case" } ; setup_valid := false ; { Virtab vor Open() neu einstellen } end ; end ; procedure TVirtabTableDEMO.Setup ; { -- Nur zur Laufzeit: wenn die Art der Virtab geaendert wird, muessen ggf. Indexfelder und Sortfelder neu gesetzt werden. } begin Close ; { falls die Virtab offen ist } if Databasename = '' then raise Exception.CreateFmt('Virtab %s: Databasename muss vor VirtabKind gesetzt werden!', [VirtabName]) ; case FVirtabKind of vtkSALES: begin { -- Index besteht aus allen PRIMAERYKEY und IDENTIFYING-Spalten } IndexFieldNames := 'SALESPERSON_ID;CUSTOMER_ID;CUSTOMER;PRODUCT_ID' ; end ; vtkDEPTS: begin { -- Index besteht aus allen PRIMAERYKEY und IDENTIFYING-Spalten } IndexFieldNames := 'REGIONAL_GROUP;DEPARTMENT_NAME' ; end ; vtkDEPTS_2: begin { -- Index besteht aus allen PRIMAERYKEY und IDENTIFYING-Spalten } IndexFieldNames := 'REGIONAL_GROUP;DEPARTMENT' ; end ; vtkDEPTS_3: begin { -- Index besteht aus allen PRIMAERYKEY und IDENTIFYING-Spalten } IndexFieldNames := 'REGIONAL_GROUP;DEPARTMENT' ; end ; vtkDEPTS_4: begin { -- Index besteht aus allen PRIMAERYKEY und IDENTIFYING-Spalten } IndexFieldNames := 'REGIONAL_GROUP;DEPARTMENT' ; end ; vtkDEPTS_5: begin { -- Index besteht aus allen PRIMAERYKEY und IDENTIFYING-Spalten } IndexFieldNames := 'REGIONAL_GROUP;DEPARTMENT' ; end ; vtkDEPTS_6: begin { -- Index besteht aus allen PRIMAERYKEY und IDENTIFYING-Spalten } IndexFieldNames := 'DEPARTMENT' ; end ; vtkletter_data: begin { -- Index besteht aus allen PRIMAERYKEY und IDENTIFYING-Spalten } IndexFieldNames := 'EMP_FIRST_NAME;EMP_LAST_NAME;EMP_DEPARTMENT;EMP_LOC' +';CUST_NAME' ; end ; vtkletter_data_emp: begin { -- Index besteht aus allen PRIMAERYKEY und IDENTIFYING-Spalten } IndexFieldNames := 'EMP_FIRST_NAME;EMP_LAST_NAME;EMP_DEPARTMENT;EMP_LOC' ; end ; vtkletter_data_cust: begin { -- Index besteht aus allen PRIMAERYKEY und IDENTIFYING-Spalten } IndexFieldNames := 'CUST_NAME' ; end ; vtkletter_data_main: begin { -- Index besteht aus allen PRIMAERYKEY und IDENTIFYING-Spalten } IndexFieldNames := 'EMP_FIRST_NAME;EMP_LAST_NAME;CUST_NAME' ; end ; vtkHIERARCHY: begin { -- Index besteht aus allen PRIMAERYKEY und IDENTIFYING-Spalten } IndexFieldNames := 'BOSS;BOSS_JOB;SLAVE;SLAVE_JOB' +';SLAVE_LOC;SLAVE_DEPT' ; end ; vtkDEPTSINFO: begin { -- Index besteht aus allen PRIMAERYKEY und IDENTIFYING-Spalten } IndexFieldNames := 'REGIONAL_GROUP;DEPARTMENT_NAME' ; end ; vtkDEPTSINFO1: begin { -- Index besteht aus allen PRIMAERYKEY und IDENTIFYING-Spalten } IndexFieldNames := 'REGIONAL_GROUP;DEPARTMENT_NAME' ; end ; end { FVirtabKind } ; end ; function TVirtabTableDEMO.BookmarkFields : string ; { -- Gibt alle IDENTIFYING- bzw. PRIMARYKEY fields zurueck, als ';'-getrennte Liste. Pro Table nur ID-fields, wenn kein PK-field.} begin case FVirtabKind of vtkSALES: result := 'SALESPERSON_ID;CUSTOMER_ID;PRODUCT_ID' ; vtkDEPTS: result := 'REGIONAL_GROUP;DEPARTMENT_NAME' ; vtkDEPTS_2: result := 'REGIONAL_GROUP;DEPARTMENT' ; vtkDEPTS_3: result := 'REGIONAL_GROUP;DEPARTMENT' ; vtkDEPTS_4: result := 'REGIONAL_GROUP;DEPARTMENT' ; vtkDEPTS_5: result := 'REGIONAL_GROUP;DEPARTMENT' ; vtkDEPTS_6: result := 'DEPARTMENT' ; vtkletter_data: result := 'cust_name;emp_department;emp_loc;emp_first_name;emp_last_name' ; vtkletter_data_emp: result := 'emp_department;emp_loc;emp_first_name;emp_last_name' ; vtkletter_data_cust: result := 'cust_name' ; vtkletter_data_main: result := 'cust_name;emp_first_name;emp_last_name' ; vtkHIERARCHY: result := 'boss;slave;boss_job;slave_job;slave_dept;slave_loc' ; vtkDEPTSINFO: result := 'REGIONAL_GROUP;DEPARTMENT_NAME' ; vtkDEPTSINFO1: result := 'REGIONAL_GROUP;DEPARTMENT_NAME' ; end { "case" } ; end ; procedure TVirtabTableDEMO.SetPersistentBookmark(bookmarkfields: string) ; { -- Werte der 'bookmarkfields' im aktuellen record merken. } var i, fidx: integer ; fieldname: string ; begin if fPersistentBookmark = nil then fPersistentBookmark := TStringList.Create else fPersistentBookmark.Clear ; while bookmarkfields <> '' do begin i := pos(';', bookmarkfields) ; if i < 1 then i := length(bookmarkfields)+1 ; fieldname := copy(bookmarkfields, 1, i-1) ; bookmarkfields := copy(bookmarkfields, i+1, 999) ; { Fieldname inkl.';' abschneiden } fidx := FieldIndexByName(fieldname) ; { Suche das Feld } IF (fidx <> -1) AND NOT Fields[fidx].IsNull AND (Fields[fidx].AsString <> '') then fPersistentBookmark.Add(IntToStr(fidx)+'='+Fields[fidx].AsString) ; { Wert in der Form '=' merken } end ; end ; procedure TVirtabTableDEMO.GotoPersistentBookmark ; { -- Record mit gemerkten Werten der 'fPersistentBookmark' suchen. } var i, fidx: integer ; gefunden: boolean ; begin { -- Suchen nach dem Datensatz, der in 'fPersistentBookmark' gemerkt wurde } gefunden := false ; while not gefunden and not Eof do begin gefunden := true ; for i := 0 to fPersistentBookmark.count-1 do begin fidx := StrToInt(fPersistentBookmark.Names[i]) ; if Fields[fidx].AsString <> fPersistentBookmark.Values[IntToStr(fidx)] then gefunden := false ; end ; if not gefunden then Next ; end ; if not gefunden then First ; end ; procedure TVirtabTableDEMO.VTBeforeOpen(Dataset:TDataset) ; begin if not setup_valid then Setup ; { ggf. neue Einstellungen erzeugen } { User-Event ausfuehren } if Assigned(FBeforeOpen) then FBeforeOpen(self) ; if FVirtabKind = vtkNone then raise Exception.CreateFmt('Virtab %s ist noch vom Typ vtkNone.', [Name]) ; end ; procedure TVirtabTableDEMO.VTOnUpdateRecord(Dataset: TDataset; UpdateKind: TUpdateKind; var UpdateAction: TUpdateAction) ; { -- Wird pro geaendertem Record aufgerufen, wenn die BDE die Datebank updatet.} begin { rufe ggf. Anwendermethode auf } if assigned(FOnUpdaterecord) then FOnUpdateRecord(Dataset, UpdateKind, UpdateAction) ; with ProceduresDEMO do case UpdateKind of ukInsert: CallProc(GetProc(fVirtabKind,1 {=InsertProc}), self, false, true) ; ukModify: CallProc(GetProc(fVirtabKind,2 {=UpdateProc}), self, false, true) ; ukDelete: CallProc(GetProc(fVirtabKind,3 {=DeleteProc}), self, true, false) ; end ; UpdateAction := uaApplied ; end ; procedure TVirtabTableDEMO.VTOnUpdateError(Dataset: TDataset; E: EDatabaseError; UpdateKind: TUpdateKind; var UpdateAction: TUpdateAction) ; { -- Wird pro Fehler aufgerufen, wenn die BDE die Datebank updatet.} begin { rufe ggf. Anwendermethode auf } if assigned(FOnUpdateError) then FOnUpdateError(Dataset, E, UpdateKind, UpdateAction) ; { Es wird nur der Fehler an die Anwendung weitergeleitet.} end ; function TVirtabTableDEMO.IsPKField(fieldname:string): boolean ; begin result := _IsPKField(FVirtabKind, fieldname) ; end ; function TVirtabTableDEMO.IsIdentField(fieldname:string): boolean ; begin result := _IsIdentField(FVirtabKind, fieldname) ; end ; function TVirtabTableDEMO.IsReadonlyField(fieldname:string): boolean ; begin result := _IsReadOnlyField(FVirtabKind, fieldname) ; end ; { ------- Query-Objekt fuer alle VirTabs ----------------------- } constructor TVirtabQueryDEMO.Create(AOwner:TComponent) ; begin inherited Create(AOwner) ; setup_valid := true ; FVirtabKind := vtkNone ; { Virtab ist noch von keiner Art } FVirtabName := '' ; FVirtabSchema := 'vtdemo' ; { aus 'er2sql -dbschema:vtdemo'} { DatabaseName := 'DEMO' ; { Nicht schon in Create, sonst Probleme } AutoCalcFields := true ; { -- in der BDE muss SQLPASSTRHRU MODE auf 'SHARED ...' } RequestLive := true ; CachedUpdates := true ; { nicht veraendern !!! } Tag := 0 ; fPersistentBookmark := nil ; UniDirectional := False ; { Sperrung moeglichst wenig restriktiv, da Aenderungen per PROC-Calls aus BDE-Sicht auch von anderen Applikationen kommen } UpdateMode := upWhereKeyOnly ; inherited BeforeOpen := VTBeforeOpen ; inherited OnUpdateRecord := VTOnUpdateRecord ; inherited OnUpdateError := VTOnUpdateError ; end ; destructor TVirtabQueryDEMO.Destroy ; begin if fPersistentBookmark <> nil then fPersistentBookmark.Free ; fPersistentBookmark := nil ; inherited Destroy ; end ; { Abwaertskompatibler Zugriff auf die Stored procs } function TVirtabQueryDEMO.InsertProc : TStoredProc ; { Rueckgabe der Eintraege aus der globalen procedure-Liste } begin result := ProceduresDEMO.GetProc(fVirtabKind, 1 {=insert}) ; end ; function TVirtabQueryDEMO.UpdateProc : TStoredProc ; begin result := ProceduresDEMO.GetProc(fVirtabKind, 2 {=update}) ; end ; function TVirtabQueryDEMO.DeleteProc : TStoredProc ; begin result := ProceduresDEMO.GetProc(fVirtabKind, 3 {=delete}) ; end ; function TVirtabQueryDEMO.AddSchema(obj: string) : string ; { -- fuegt evtl. den Schemabezeichner vor einem DB-Objekt ein } begin if FVirtabSchema = '' then AddSchema := obj else AddSchema := FVirtabSchema + '.' + obj ; end ; function TVirtabQueryDEMO.FieldIndexByName(fieldname:string):integer ; { -- gibt den Index des Feldes in Fields zurueck; oder -1, wenn es nicht gefunden wurde } var f: TField ; begin f := FindField(fieldname) ; if f = nil then result := -1 else result := f.Index ; end ; procedure TVirtabQueryDEMO.SetKind(vk: TVirtabKindDEMO) ; { -- Wenn die Art der Virtab geaendert wird, muessen * zur Designzeit der Name * zur Laufzeit alle Einstellungen neu gesetzt werden. } var found : boolean ; i : integer ; begin if FVirtabKind <> vk then begin { nur bei wirklichen Aenderungen was tun } { Loesche alte Prozeduren } FVirtabKind := vk ; case FVirtabKind of vtkSALES: begin FVirtabName := 'SALES' ; end ; vtkDEPTS: begin FVirtabName := 'DEPTS' ; end ; vtkDEPTS_2: begin FVirtabName := 'DEPTS_2' ; end ; vtkDEPTS_3: begin FVirtabName := 'DEPTS_3' ; end ; vtkDEPTS_4: begin FVirtabName := 'DEPTS_4' ; end ; vtkDEPTS_5: begin FVirtabName := 'DEPTS_5' ; end ; vtkDEPTS_6: begin FVirtabName := 'DEPTS_6' ; end ; vtkletter_data: begin FVirtabName := 'letter_data' ; end ; vtkletter_data_emp: begin FVirtabName := 'letter_data_emp' ; end ; vtkletter_data_cust: begin FVirtabName := 'letter_data_cust' ; end ; vtkletter_data_main: begin FVirtabName := 'letter_data_main' ; end ; vtkHIERARCHY: begin FVirtabName := 'HIERARCHY' ; end ; vtkDEPTSINFO: begin FVirtabName := 'DEPTSINFO' ; end ; vtkDEPTSINFO1: begin FVirtabName := 'DEPTSINFO1' ; end ; else begin FVirtabName := '' ; end ; end { "case" } ; setup_valid := false ; { Virtab vor Open() neu einstellen } end ; { SQL-Text checken: der Name der neuen Virtab muss drin vorkommen! } if SQL.Count = 0 then SQL.Add('SELECT * FROM '+UpperCase('vt_'+FVirtabName)) ; if FVirtabKind <> vtkNone then begin found := false ; for i := 0 to SQL.Count-1 do if pos(UpperCase(FVirtabName), Uppercase(SQL[i])) > 0 then found := true ; if not found then MessageDlg(Format('Im Select-statement in property "SQL[]" kommt der Virtabname "%s" nicht vor!',[FVirtabName]), mtWarning, [mbOk], 0) ; end ; end ; procedure TVirtabQueryDEMO.Setup ; { -- Nur zur Laufzeit: wenn die Art der Virtab geaendert wird, muessen ggf. Indexfelder und Sortfelder neu gesetzt werden. } begin Close ; { falls die Virtab offen ist } if Databasename = '' then raise Exception.CreateFmt('Virtab %s: Databasename muss vor VirtabKind gesetzt werden!', [VirtabName]) ; case FVirtabKind of vtkSALES: begin end ; vtkDEPTS: begin end ; vtkDEPTS_2: begin end ; vtkDEPTS_3: begin end ; vtkDEPTS_4: begin end ; vtkDEPTS_5: begin end ; vtkDEPTS_6: begin end ; vtkletter_data: begin end ; vtkletter_data_emp: begin end ; vtkletter_data_cust: begin end ; vtkletter_data_main: begin end ; vtkHIERARCHY: begin end ; vtkDEPTSINFO: begin end ; vtkDEPTSINFO1: begin end ; end { FVirtabKind } ; end ; function TVirtabQueryDEMO.BookmarkFields : string ; { -- Gibt alle IDENTIFYING- bzw. PRIMARYKEY fields zurueck, als ';'-getrennte Liste. Pro Table nur ID-fields, wenn kein PK-field.} begin case FVirtabKind of vtkSALES: result := 'SALESPERSON_ID;CUSTOMER_ID;PRODUCT_ID' ; vtkDEPTS: result := 'REGIONAL_GROUP;DEPARTMENT_NAME' ; vtkDEPTS_2: result := 'REGIONAL_GROUP;DEPARTMENT' ; vtkDEPTS_3: result := 'REGIONAL_GROUP;DEPARTMENT' ; vtkDEPTS_4: result := 'REGIONAL_GROUP;DEPARTMENT' ; vtkDEPTS_5: result := 'REGIONAL_GROUP;DEPARTMENT' ; vtkDEPTS_6: result := 'DEPARTMENT' ; vtkletter_data: result := 'cust_name;emp_department;emp_loc;emp_first_name;emp_last_name' ; vtkletter_data_emp: result := 'emp_department;emp_loc;emp_first_name;emp_last_name' ; vtkletter_data_cust: result := 'cust_name' ; vtkletter_data_main: result := 'cust_name;emp_first_name;emp_last_name' ; vtkHIERARCHY: result := 'boss;slave;boss_job;slave_job;slave_dept;slave_loc' ; vtkDEPTSINFO: result := 'REGIONAL_GROUP;DEPARTMENT_NAME' ; vtkDEPTSINFO1: result := 'REGIONAL_GROUP;DEPARTMENT_NAME' ; end { "case" } ; end ; procedure TVirtabQueryDEMO.SetPersistentBookmark(bookmarkfields: string) ; { -- Werte der 'bookmarkfields' im aktuellen record merken. } var i, fidx: integer ; fieldname: string ; begin if fPersistentBookmark = nil then fPersistentBookmark := TStringList.Create else fPersistentBookmark.Clear ; while bookmarkfields <> '' do begin i := pos(';', bookmarkfields) ; if i < 1 then i := length(bookmarkfields)+1 ; fieldname := copy(bookmarkfields, 1, i-1) ; bookmarkfields := copy(bookmarkfields, i+1, 999) ; { Fieldname inkl.';' abschneiden } fidx := FieldIndexByName(fieldname) ; { Suche das Feld } IF (fidx <> -1) AND NOT Fields[fidx].IsNull AND (Fields[fidx].AsString <> '') then fPersistentBookmark.Add(IntToStr(fidx)+'='+Fields[fidx].AsString) ; { Wert in der Form '=' merken } end ; end ; procedure TVirtabQueryDEMO.GotoPersistentBookmark ; { -- Record mit gemerkten Werten der 'fPersistentBookmark' suchen. } var i, fidx: integer ; gefunden: boolean ; begin { -- Suchen nach dem Datensatz, der in 'fPersistentBookmark' gemerkt wurde } gefunden := false ; while not gefunden and not Eof do begin gefunden := true ; for i := 0 to fPersistentBookmark.count-1 do begin fidx := StrToInt(fPersistentBookmark.Names[i]) ; if Fields[fidx].AsString <> fPersistentBookmark.Values[IntToStr(fidx)] then gefunden := false ; end ; if not gefunden then Next ; end ; if not gefunden then First ; end ; procedure TVirtabQueryDEMO.Refresh ; { -- Macht Close/Open auf der TQuery, faehrt den Datensatz dann wieder ueber gemerkte Schluesselfelder an.} begin SetPersistentBookmark(BookmarkFields) ; Close ; Open ; GotoPersistentBookmark ; end ; procedure TVirtabQueryDEMO.VTBeforeOpen(Dataset:TDataset) ; begin if not setup_valid then Setup ; { ggf. neue Einstellungen erzeugen } { User-Event ausfuehren } if Assigned(FBeforeOpen) then FBeforeOpen(self) ; if FVirtabKind = vtkNone then raise Exception.CreateFmt('Virtab %s ist noch vom Typ vtkNone.', [Name]) ; LogText('Virtab '+FVirtabName+', BeforeOpen(). SQL =', SQL) ; end ; procedure TVirtabQueryDEMO.VTOnUpdateRecord(Dataset: TDataset; UpdateKind: TUpdateKind; var UpdateAction: TUpdateAction) ; { -- Wird pro geaendertem Record aufgerufen, wenn die BDE die Datebank updatet.} begin { rufe ggf. Anwendermethode auf } if assigned(FOnUpdaterecord) then FOnUpdateRecord(Dataset, UpdateKind, UpdateAction) ; with ProceduresDEMO do case UpdateKind of ukInsert: CallProc(GetProc(fVirtabKind,1 {=InsertProc}), self, false, true) ; ukModify: CallProc(GetProc(fVirtabKind,2 {=UpdateProc}), self, false, true) ; ukDelete: CallProc(GetProc(fVirtabKind,3 {=DeleteProc}), self, true, false) ; end ; UpdateAction := uaApplied ; end ; procedure TVirtabQueryDEMO.VTOnUpdateError(Dataset: TDataset; E: EDatabaseError; UpdateKind: TUpdateKind; var UpdateAction: TUpdateAction) ; { -- Wird pro Fehler aufgerufen, wenn die BDE die Datebank updatet.} begin { rufe ggf. Anwendermethode auf } if assigned(FOnUpdateError) then FOnUpdateError(Dataset, E, UpdateKind, UpdateAction) ; { Es wird nur der Fehler an die Anwendung weitergeleitet.} end ; function TVirtabQueryDEMO.IsPKField(fieldname:string): boolean ; begin result := _IsPKField(FVirtabKind, fieldname) ; end ; function TVirtabQueryDEMO.IsIdentField(fieldname:string): boolean ; begin result := _IsIdentField(FVirtabKind, fieldname) ; end ; function TVirtabQueryDEMO.IsReadonlyField(fieldname:string): boolean ; begin result := _IsReadOnlyField(FVirtabKind, fieldname) ; end ; INITIALIZATION VirtabLogFile := '' ; ProceduresDEMO := TProceduresDEMO.Create ; end .