ADOUpdateSQL源码
浏览数：69 /
时间：2015年06月12日
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.
郑重声明：本站内容如果来自互联网及其他传播媒体，其版权均属原媒体及文章作者所有。转载目的在于传递更多信息及用于网络分享，并不代表本站赞同其观点和对其真实性负责，也不构成任何其他建议。
