ADOUpdateSQL源码

  1 {***************************************************************
  2  *
  3  * Unit Name: ADOUpdateSQL
  4  * Purpose  :
  5  * Author   : Fred Schetterer
  6  * History  : 12-Mar-2000 - Created
  7  *
  8  * Copyright ?1994-2000 by FreDsterWare ComputerTools Ltd.
  9  *
 10  ****************************************************************}
 11 
 12 unit ADOUpdateSQL;
 13 
 14 interface
 15 
 16 uses
 17    Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
 18    Db, ADOInt, ADODB;
 19 
 20 type
 21    TUpdateErrorEvent = procedure(DataSet: TDataSet; E: EDatabaseError; UpdateKind: TUpdateKind; var UpdateAction: TUpdateAction) of object;
 22    TADOUpdateSQL = class;
 23 
 24    TADOUpdDataSet = class(TADODataSet)
 25    private
 26       { Private declarations }
 27       FUpdateObject: TADOUpdateSQL;
 28       FOnUpdateRecord: TUpdateRecordEvent;
 29       fOnUpdateError: TUpdateErrorEvent;
 30       procedure SetUpdateObject(Value: TADOUpdateSQL);
 31       function UpdatePending(var UpdateKind: TUpdateKind): boolean;
 32    protected
 33       { Protected declarations }
 34       procedure ApplyUpdates(AffectRecords: TAffectRecords);
 35    public
 36       { Public declarations }
 37       procedure UpdateBatch(AffectRecords: TAffectRecords = arAll); reintroduce;
 38    published
 39       { Published declarations }
 40       property UpdateObject: TADOUpdateSQL read FUpdateObject write SetUpdateObject;
 41       { Events }
 42       //property OnUpdateRecord: TUpdateRecordEvent read FOnUpdateRecord write FOnUpdateRecord;
 43       property OnUpdateError: TUpdateErrorEvent read fOnUpdateError write fOnUpdateError;
 44    end;
 45 
 46    TADOUpdateSQL = class(TComponent)
 47    private
 48       { Private declarations }
 49       FDataSet: TADOUpdDataSet;
 50       FQueries: array[TUpdateKind] of TADOQuery;
 51       FSQLText: array[TUpdateKind] of TStrings;
 52       function GetQuery(UpdateKind: TUpdateKind): TADOQuery;
 53       function GetSQL(UpdateKind: TUpdateKind): TStrings;
 54       function GetSQLIndex(Index: Integer): TStrings;
 55       procedure SetSQL(UpdateKind: TUpdateKind; Value: TStrings);
 56       procedure SetSQLIndex(Index: Integer; Value: TStrings);
 57    protected
 58       { Protected declarations }
 59       function GetDataSet: TADOUpdDataSet;
 60       procedure SetDataSet(ADataSet: TADOUpdDataSet);
 61       procedure SQLChanged(Sender: TObject);
 62    public
 63       { Public declarations }
 64       constructor Create(AOwner: TComponent); override;
 65       destructor Destroy; override;
 66       property DataSet: TADOUpdDataSet read GetDataSet write SetDataSet;
 67       procedure Apply(UpdateKind: TUpdateKind);
 68       procedure ExecSQL(UpdateKind: TUpdateKind);
 69       procedure SetParams(UpdateKind: TUpdateKind);
 70       property Query[UpdateKind: TUpdateKind]: TADOQuery read GetQuery;
 71       property SQL[UpdateKind: TUpdateKind]: TStrings read GetSQL write SetSQL;
 72    published
 73       { Published declarations }
 74       property ModifySQL: TStrings index 0 read GetSQLIndex write SetSQLIndex;
 75       property InsertSQL: TStrings index 1 read GetSQLIndex write SetSQLIndex;
 76       property DeleteSQL: TStrings index 2 read GetSQLIndex write SetSQLIndex;
 77    end;
 78 
 79 procedure Register;
 80 
 81 implementation
 82 
 83 resourcestring
 84    rsUpdateFailed                       = ‘Update failed‘;
 85 
 86 procedure Register;
 87 begin
 88    RegisterComponents(‘FreDsterWare‘, [TADOUpdDataSet, TADOUpdateSQL]);
 89 end;
 90 
 91 { TADOUpdDataSet }
 92 
 93 {-----------------------------------------------------
 94           TADOUpdDataSet.SetUpdateObject
 95 
 96  * Purpose  : Set the UpdateObject
 97               If another dataset already references this updateobject, then remove the reference
 98  * Author   : Fred Schetterer
 99  * History  :
100               12-Mar-2000 - Created
101 --------------------------------------------------------}
102 
103 procedure TADOUpdDataSet.SetUpdateObject(Value: TADOUpdateSQL);
104 begin
105    if Value <> FUpdateObject then
106    begin
107       if Assigned(FUpdateObject) and (FUpdateObject.DataSet = Self) then
108          FUpdateObject.DataSet := nil;
109       FUpdateObject := Value;
110       if Assigned(FUpdateObject) then
111       begin
112          if Assigned(FUpdateObject.DataSet) and
113             (FUpdateObject.DataSet <> Self) then
114             FUpdateObject.DataSet.UpdateObject := nil;
115          FUpdateObject.DataSet := Self;
116       end;
117    end;
118 end;
119 {-----------------------------------------------------
120           TADOUpdDataSet.UpdateBatch
121 
122  * Purpose  :
123  * Author   : Fred Schetterer
124  * History  :
125               12-Mar-2000 - Created
126 --------------------------------------------------------}
127 
128 procedure TADOUpdDataSet.UpdateBatch(AffectRecords: TAffectRecords);
129 begin
130    if Assigned(FUpdateObject)
131       or Assigned(FOnUpdateRecord) then
132       ApplyUpdates(AffectRecords)
133    else
134       inherited UpdateBatch(AffectRecords);
135 end;
136 {-----------------------------------------------------
137           TADOUpdDataSet.ApplyUpdates
138 
139  * Purpose  :
140  * Author   : Fred Schetterer
141  * History  :
142               12-Mar-2000 - Created
143 --------------------------------------------------------}
144 
145 procedure TADOUpdDataSet.ApplyUpdates(AffectRecords: TAffectRecords);
146 var
147    UpdateAction                         : TUpdateAction;
148    UpdateKind                           : TUpdateKind;
149    SavedFilter                          : string;
150    SavedFilterGroup                     : TFilterGroup;
151    wasFiltered                          : Boolean;
152 
153    RequeryNeeded                        : Boolean;
154 begin
155 
156    SavedFilter := Filter;
157    SavedFilterGroup := FilterGroup;
158    wasFiltered := Filtered;
159    FilterGroup := fgNone;
160    RequeryNeeded := False;
161 
162    CheckBrowseMode;
163    if not isEmpty then
164    begin
165       DisableControls;
166       try
167          UpdateCursorPos;
168          if not (RecordSet.EOF and RecordSet.BOF) then
169          begin
170             RecordSet.Filter := adFilterPendingRecords;
171             if not (RecordSet.EOF and RecordSet.BOF) then
172             begin
173                RecordSet.MoveFirst;
174                while not RecordSet.Eof do
175                begin
176                   if (Recordset.Status and adRecDeleted) = adRecDeleted then
177                   begin
178                      UpdateAction := uaFail;
179                      UpdateKind := ukDelete;
180                      try
181                         RequeryNeeded := True;
182                         Recordset.CancelBatch(adAffectCurrent);
183                         FUpdateObject.Apply(UpdateKind);
184                      except
185                         on E: EDatabaseError do
186                            if Assigned(OnUpdateError) then
187                               OnUpdateError(Self, E, UpdateKind, UpdateAction)
188                      end;
189                   end;
190                   RecordSet.MoveNext;
191                end;
192             end;
193             RecordSet.Filter := adFilterPendingRecords;
194          end;
195 
196          FilterGroup := fgPendingRecords;
197          Filtered := true;
198          if not (EOF and BOF) then
199          begin
200             First;
201             while not Eof do
202             begin
203                UpdateCursorPos;
204                if UpdatePending(UpdateKind) then
205                begin
206                   RequeryNeeded := RequeryNeeded or (UpdateKind <> ukModify);
207                   UpdateAction := uaFail;
208                   if Assigned(FOnUpdateRecord) then
209                      FOnUpdateRecord(self, UpdateKind, UpdateAction)
210                   else
211                   begin
212                      try
213                         FUpdateObject.Apply(UpdateKind);
214                      except
215                         on E: EDatabaseError do
216                            if Assigned(OnUpdateError) then
217                               OnUpdateError(Self, E, UpdateKind, UpdateAction)
218                      end;
219                      Recordset.CancelBatch(adAffectCurrent);
220                   end;
221                end;
222                Next;
223             end;
224          end;
225       finally
226          FilterGroup := fgNone;
227          FilterGroup := SavedFilterGroup;
228          Filter := SavedFilter;
229          Filtered := wasFiltered;
230 
231          if RequeryNeeded then
232             Requery
233          else
234             Refresh;
235          EnableControls;
236       end;
237    end;
238 end;
239 {-----------------------------------------------------
240           TADOUpdDataSet.UpdatePending
241 
242  * Purpose  : Map UpdateStatus to UpdateKind
243  * Author   : Fred Schetterer
244  * History  :
245               12-Mar-2000 - Created
246 --------------------------------------------------------}
247 
248 function TADOUpdDataSet.UpdatePending(var UpdateKind: TUpdateKind): boolean;
249 var
250    AUpdateStatus                        : TUpdateStatus;
251 begin
252    AUpdateStatus := UpdateStatus;
253    Result := (AUpdateStatus <> usUnmodified);
254    if Result then
255       UpdateKind := TUpdateKind(Ord(AUpdateStatus) - 1);
256 end;
257 
258 { TADOUpdateSQL }
259 
260 {-----------------------------------------------------
261           TADOUpdateSQL.Apply
262 
263  * Purpose  :
264  * Author   : Fred Schetterer
265  * History  :
266               12-Mar-2000 - Created
267 --------------------------------------------------------}
268 
269 procedure TADOUpdateSQL.Apply(UpdateKind: TUpdateKind);
270 begin
271    SetParams(UpdateKind);
272    ExecSQL(UpdateKind);
273 end;
274 {-----------------------------------------------------
275           TADOUpdateSQL.Create
276 
277  * Purpose  :
278  * Author   : Fred Schetterer
279  * History  :
280               12-Mar-2000 - Created
281 --------------------------------------------------------}
282 
283 constructor TADOUpdateSQL.Create(AOwner: TComponent);
284 var
285    UpdateKind                           : TUpdateKind;
286 begin
287    inherited Create(AOwner);
288    for UpdateKind := Low(TUpdateKind) to High(TUpdateKind) do
289    begin
290       FSQLText[UpdateKind] := TStringList.Create;
291       TStringList(FSQLText[UpdateKind]).OnChange := SQLChanged;
292    end;
293 
294 {$IFDEF UNREGISTERED}
295    if not (csDesigning in ComponentState) then              { running outside IDE}
296       if (FindWindowEx(0, 0, ‘TAppBuilder‘, nil) = 0) then
297       begin                                                 { Delphi not found}
298          Application.NormalizeTopMosts;
299          ShowMessage(Self.ClassName + ‘ is NOT a public domain product, if you find it usefull then please register it..‘);
300          Application.RestoreTopMosts;
301       end;
302 {$ENDIF}
303 
304 end;
305 
306 {-----------------------------------------------------
307           TADOUpdateSQL.Destroy
308 
309  * Purpose  :
310  * Author   : Fred Schetterer
311  * History  :
312               12-Mar-2000 - Created
313 --------------------------------------------------------}
314 
315 destructor TADOUpdateSQL.Destroy;
316 var
317    UpdateKind                           : TUpdateKind;
318 begin
319    if Assigned(FDataSet) and (FDataSet.UpdateObject = Self) then
320       FDataSet.UpdateObject := nil;
321    for UpdateKind := Low(TUpdateKind) to High(TUpdateKind) do
322       FSQLText[UpdateKind].Free;
323    inherited Destroy;
324 end;
325 {-----------------------------------------------------
326           TADOUpdateSQL.ExecSQL
327 
328  * Purpose  :
329  * Author   : Fred Schetterer
330  * History  :
331               12-Mar-2000 - Created
332 --------------------------------------------------------}
333 
334 procedure TADOUpdateSQL.ExecSQL(UpdateKind: TUpdateKind);
335 begin
336    with Query[UpdateKind] do
337    begin
338       Prepared := True;
339       ExecSQL;
340       if (RowsAffected = 0) then
341          DatabaseError(rsUpdateFailed);
342    end;
343 end;
344 
345 {-----------------------------------------------------
346           TADOUpdateSQL.GetQuery
347 
348  * Purpose  :
349  * Author   : Fred Schetterer
350  * History  :
351               12-Mar-2000 - Created
352 --------------------------------------------------------}
353 
354 function TADOUpdateSQL.GetQuery(UpdateKind: TUpdateKind): TADOQuery;
355 begin
356    if not Assigned(FQueries[UpdateKind]) then
357    begin
358       FQueries[UpdateKind] := TADOQuery.Create(Self);
359       FQueries[UpdateKind].SQL.Assign(FSQLText[UpdateKind]);
360       if Assigned(FDataSet.Connection) then
361          FQueries[UpdateKind].Connection := FDataSet.Connection
362       else
363          FQueries[UpdateKind].ConnectionString := FDataSet.ConnectionString;
364    end;
365    Result := FQueries[UpdateKind];
366 end;
367 
368 {-----------------------------------------------------
369           TADOUpdateSQL.GetSQL
370 
371  * Purpose  :
372  * Author   : Fred Schetterer
373  * History  :
374               12-Mar-2000 - Created
375 --------------------------------------------------------}
376 
377 function TADOUpdateSQL.GetSQL(UpdateKind: TUpdateKind): TStrings;
378 begin
379    Result := FSQLText[UpdateKind];
380 end;
381 {-----------------------------------------------------
382           TADOUpdateSQL.GetSQLIndex
383 
384  * Purpose  :
385  * Author   : Fred Schetterer
386  * History  :
387               12-Mar-2000 - Created
388 --------------------------------------------------------}
389 
390 function TADOUpdateSQL.GetSQLIndex(Index: Integer): TStrings;
391 begin
392    Result := FSQLText[TUpdateKind(Index)];
393 end;
394 {-----------------------------------------------------
395           TADOUpdateSQL.GetDataSet
396 
397  * Purpose  :
398  * Author   : Fred Schetterer
399  * History  :
400               12-Mar-2000 - Created
401 --------------------------------------------------------}
402 
403 function TADOUpdateSQL.GetDataSet: TADOUpdDataSet;
404 begin
405    Result := FDataSet;
406 end;
407 {-----------------------------------------------------
408           TADOUpdateSQL.SetDataSet
409 
410  * Purpose  :
411  * Author   : Fred Schetterer
412  * History  :
413               12-Mar-2000 - Created
414 --------------------------------------------------------}
415 
416 procedure TADOUpdateSQL.SetDataSet(ADataSet: TADOUpdDataSet);
417 begin
418    FDataSet := ADataSet;
419 end;
420 
421 {-----------------------------------------------------
422           TADOUpdateSQL.SetParams
423 
424  * Purpose  :
425  * Author   : Fred Schetterer
426  * History  :
427               12-Mar-2000 - Created
428 --------------------------------------------------------}
429 
430 procedure TADOUpdateSQL.SetParams(UpdateKind: TUpdateKind);
431 var
432    I                                    : Integer;
433    isOld                                : Boolean;
434    Parameter                            : TParameter;
435    ParameterName                        : string;
436    AValue                               : Variant;
437    ADOField                             : OleVariant;
438 begin
439    if not Assigned(FDataSet) then Exit;
440 
441    with Query[UpdateKind] do
442    begin
443       Parameters.ParseSQL(SQL.Text, True);
444       for I := 0 to Parameters.Count - 1 do
445       begin
446          Parameter := Parameters.Items[I];
447          ParameterName := Parameter.Name;
448          isOld := CompareText (Copy(ParameterName, 1, 4), ‘OLD_‘) = 0;
449          if isOld then
450             System.Delete(ParameterName, 1, 4);
451          if not Assigned(FDataSet.FindField(ParameterName)) then
452             Continue;
453 
454          ADOField := FDataSet.Recordset.Fields[ParameterName];
455          if isOld then
456             AValue := ADOField.OriginalValue
457          else
458             if VarIsEmpty(ADOField.Value) or VarIsNull(ADOField.Value) then
459          begin
460             Parameter.ParameterObject.Type_ := FDataSet.Recordset.Fields[ParameterName].Type_;
461             AValue := NULL;
462          end
463          else
464             AValue := ADOField.Value;
465          Parameter.Value := AValue;
466       end;
467    end;
468 
469 end;
470 
471 {-----------------------------------------------------
472           TADOUpdateSQL.SetSQL
473 
474  * Purpose  :
475  * Author   : Fred Schetterer
476  * History  :
477               12-Mar-2000 - Created
478 --------------------------------------------------------}
479 
480 procedure TADOUpdateSQL.SetSQL(UpdateKind: TUpdateKind; Value: TStrings);
481 begin
482    FSQLText[UpdateKind].Assign(Value);
483 end;
484 {-----------------------------------------------------
485           TADOUpdateSQL.SetSQLIndex
486 
487  * Purpose  :
488  * Author   : Fred Schetterer
489  * History  :
490               12-Mar-2000 - Created
491 --------------------------------------------------------}
492 
493 procedure TADOUpdateSQL.SetSQLIndex(Index: Integer; Value: TStrings);
494 begin
495    SetSQL(TUpdateKind(Index), Value);
496 end;
497 {-----------------------------------------------------
498           TADOUpdateSQL.SQLChanged
499 
500  * Purpose  :
501  * Author   : Fred Schetterer
502  * History  :
503               12-Mar-2000 - Created
504 --------------------------------------------------------}
505 
506 procedure TADOUpdateSQL.SQLChanged(Sender: TObject);
507 var
508    UpdateKind                           : TUpdateKind;
509 begin
510    for UpdateKind := Low(TUpdateKind) to High(TUpdateKind) do
511       if Sender = FSQLText[UpdateKind] then
512       begin
513          if Assigned(FQueries[UpdateKind]) then
514          begin
515             FQueries[UpdateKind].Parameters.Clear;
516             FQueries[UpdateKind].SQL.Assign(FSQLText[UpdateKind]);
517          end;
518          Break;
519       end;
520 end;
521 
522 end.