trunk/runtime/IBBatchMove.pas

{************************************************************************}
{                                                                        }
{       Borland Delphi Visual Component Library                          }
{       InterBase Express core components                                }
{                                                                        }
{       Copyright (c) 1998-2000 Inprise Corporation                      }
{                                                                        }
{    InterBase Express is based in part on the product                   }
{    Free IB Components, written by Gregory H. Deatz for                 }
{    Hoagland, Longo, Moran, Dunst & Doukas Company.                     }
{    Free IB Components is used under license.                           }
{                                                                        }
{    The contents of this file are subject to the InterBase              }
{    Public License Version 1.0 (the "License"); you may not             }
{    use this file except in compliance with the License. You            }
{    may obtain a copy of the License at http://www.Inprise.com/IPL.html }
{    Software distributed under the License is distributed on            }
{    an "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either              }
{    express or implied. See the License for the specific language       }
{    governing rights and limitations under the License.                 }
{    The Original Code was created by InterBase Software Corporation     }
{       and its successors.                                              }
{    Portions created by Inprise Corporation are Copyright (C) Inprise   }
{       Corporation. All Rights Reserved.                                }
{    Contributor(s): Jeff Overcash                                       }
{                                                                        }
{    IBX For Lazarus (Firebird Express)                                  }
{    Contributor: Tony Whyman, MWA Software http://www.mwasoftware.co.uk }
{    Portions created by MWA Software are copyright McCallum Whyman      }
{    Associates Ltd 2011 - 2018                                               }
{                                                                        }
{************************************************************************}

unit IBBatchMove;

{$Mode Delphi}

interface

uses
{$IFDEF WINDOWS }
  Windows,
{$ELSE}
  unix,
{$ENDIF}
  SysUtils, Classes,  Db,
     IB, IBCustomDataSet, IBDatabase, IBTable;

type
  TBatchMode = (batAppend, batUpdate, batAppendUpdate, batDelete, batCopy);

{ TBatchMove }

  TIBBatchMove = class(TComponent)
  private
    FDestination: TIBTable;
    FSource: TIBCustomDataSet;
    FMode: TBatchMode;
    FAbortOnKeyViol: Boolean;
    FAbortOnProblem: Boolean;
    FTransliterate: Boolean;
    FRecordCount: Longint;
    FMovedCount: Longint;
    FKeyViolCount: Longint;
    FProblemCount: Longint;
    FChangedCount: Longint;
    FMappings: TStrings;
    FKeyViolTableName: TFileName;
    FProblemTableName: TFileName;
    FChangedTableName: TFileName;
    FCommitCount: Integer;
    procedure SetMappings(Value: TStrings);
    procedure SetSource(Value: TIBCustomDataSet);
    procedure InternalExecute (BatchMode: TBatchMode; FieldCount: Word);
  protected
    procedure Notification(AComponent: TComponent;
      Operation: TOperation); override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Execute;
  public
    property ChangedCount: Longint read FChangedCount;
    property KeyViolCount: Longint read FKeyViolCount;
    property MovedCount: Longint read FMovedCount;
    property ProblemCount: Longint read FProblemCount;
  published
    property AbortOnKeyViol: Boolean read FAbortOnKeyViol write FAbortOnKeyViol
                                                          default True;
    property AbortOnProblem: Boolean read FAbortOnProblem write FAbortOnProblem
                                                          default True;
    property CommitCount: Integer read FCommitCount write FCommitCount default 0;
    property ChangedTableName: TFileName read FChangedTableName write FChangedTableName;
    property Destination: TIBTable read FDestination write FDestination;
    property KeyViolTableName: TFileName read FKeyViolTableName write FKeyViolTableName;
    property Mappings: TStrings read FMappings write SetMappings;
    property Mode: TBatchMode read FMode write FMode default batAppend;
    property ProblemTableName: TFileName read FProblemTableName write FProblemTableName;
    property RecordCount: Longint read FRecordCount write FRecordCount default 0;
    property Source: TIBCustomDataSet read FSource write SetSource;
    property Transliterate: Boolean read FTransliterate write FTransliterate
                                                        default True;
  end;

implementation

uses FBMessages;

{ TIBBatchMove }

constructor TIBBatchMove.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FAbortOnKeyViol := True;
  FAbortOnProblem := True;
  FTransliterate := True;
  FMappings := TStringList.Create;
end;

destructor TIBBatchMove.Destroy;
begin
  if FMappings <> nil then
    FMappings.Free;
  inherited Destroy;
end;

procedure TIBBatchMove.Execute;
type
  TFieldMap = array of Word;
var
  SourceActive, DestinationActive: Boolean;
  BatchMode: TBatchMode;
  I: Integer;
  FieldCount: Word;
  FieldMap: TFieldMap;
  DestName, SourceName: string;

  procedure GetMappingNames;
  var
    P: Integer;
    Mapping: string;
  begin
    Mapping := FMappings[I];
    P := Pos('=', Mapping); {MBCS OK}
    if P > 0 then
    begin
      DestName := Copy(Mapping, 1, P - 1);
      SourceName := Copy(Mapping, P + 1, 255);
    end
    else begin
      DestName := Mapping;
      SourceName := Mapping;
    end;
  end;

begin
  if (Destination = nil) or (Source = nil) or (Destination = Source) then
    IBError(ibxeInvalidBatchMove, [nil]);
  SourceActive := Source.Active;
  DestinationActive := Destination.Active;
  FieldCount := 0;
  FieldMap := nil;
  try
    Source.DisableControls;
    Destination.DisableControls;
    Source.Open;
    Source.CheckBrowseMode;
    Source.UpdateCursorPos;
    BatchMode := FMode;
    if BatchMode = batCopy then
    begin
      Destination.Close;
      if FMappings.Count = 0 then
        Destination.FieldDefs := Source.FieldDefs
      else
      begin
        Destination.FieldDefs.Clear;
        for I := 0 to FMappings.Count - 1 do
        begin
          GetMappingNames;
          with Source.FieldDefs.Find(SourceName) do
            Destination.FieldDefs.Add(DestName, DataType, Size, Required);
        end;
      end;
      Destination.IndexDefs.Clear;
      Destination.CreateTable;
      BatchMode := batAppend;
    end;
    Destination.Open;
    Destination.CheckBrowseMode;
    if FMappings.Count <> 0 then
    begin
      FieldCount := Destination.FieldDefs.Count;
      SetLength(FieldMap, FieldCount);
      for I := 0 to FMappings.Count - 1 do
      begin
        GetMappingNames;
        FieldMap[Destination.FieldDefs.Find(DestName).FieldNo-1] :=
          Source.FieldDefs.Find(SourceName).FieldNo;
      end;
    end;
    if FRecordCount > 0 then
    begin
      Source.UpdateCursorPos;
      FMovedCount := FRecordCount;
    end else
    begin
      FMovedCount := MaxLongint;
    end;
    Source.CursorPosChanged;
    try
      InternalExecute (BatchMode, FieldCount);
    finally
      if DestinationActive then Destination.First;
    end;
  finally
    if not DestinationActive then
      Destination.Close;
    if not SourceActive then
      Source.Close;
    Destination.EnableControls;
    Source.EnableControls;
  end;
end;

procedure TIBBatchMove.Notification(AComponent: TComponent;
  Operation: TOperation);
begin
  inherited Notification(AComponent, Operation);
  if Operation = opRemove then
  begin
    if Destination = AComponent then
      Destination := nil;
    if Source = AComponent then
      Source := nil;
  end;
end;

procedure TIBBatchMove.SetMappings(Value: TStrings);
begin
  FMappings.Assign(Value);
end;

procedure TIBBatchMove.SetSource(Value: TIBCustomDataSet);
begin
  FSource := Value;
  if Value <> nil then
    Value.FreeNotification(Self);
end;


procedure TIBBatchMove.InternalExecute (BatchMode: TBatchMode; FieldCount: Word);
begin

end;

end.
Revision:	143
Committed:	Fri Feb 23 12:11:21 2018 UTC (6 years, 9 months ago) by tony
Content type:	text/x-pascal
File size:	8474 byte(s)
Log Message:	Fixes Merged
#	Content
1	{************************************************************************}
2	{ }
3	{ Borland Delphi Visual Component Library }
4	{ InterBase Express core components }
5	{ }
6	{ Copyright (c) 1998-2000 Inprise Corporation }
7	{ }
8	{ InterBase Express is based in part on the product }
9	{ Free IB Components, written by Gregory H. Deatz for }
10	{ Hoagland, Longo, Moran, Dunst & Doukas Company. }
11	{ Free IB Components is used under license. }
12	{ }
13	{ The contents of this file are subject to the InterBase }
14	{ Public License Version 1.0 (the "License"); you may not }
15	{ use this file except in compliance with the License. You }
16	{ may obtain a copy of the License at http://www.Inprise.com/IPL.html }
17	{ Software distributed under the License is distributed on }
18	{ an "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either }
19	{ express or implied. See the License for the specific language }
20	{ governing rights and limitations under the License. }
21	{ The Original Code was created by InterBase Software Corporation }
22	{ and its successors. }
23	{ Portions created by Inprise Corporation are Copyright (C) Inprise }
24	{ Corporation. All Rights Reserved. }
25	{ Contributor(s): Jeff Overcash }
26	{ }
27	{ IBX For Lazarus (Firebird Express) }
28	{ Contributor: Tony Whyman, MWA Software http://www.mwasoftware.co.uk }
29	{ Portions created by MWA Software are copyright McCallum Whyman }
30	{ Associates Ltd 2011 - 2018 }
31	{ }
32	{************************************************************************}
33
34	unit IBBatchMove;
35
36	{$Mode Delphi}
37
38	interface
39
40	uses
41	{$IFDEF WINDOWS }
42	Windows,
43	{$ELSE}
44	unix,
45	{$ENDIF}
46	SysUtils, Classes, Db,
47	IB, IBCustomDataSet, IBDatabase, IBTable;
48
49	type
50	TBatchMode = (batAppend, batUpdate, batAppendUpdate, batDelete, batCopy);
51
52	{ TBatchMove }
53
54	TIBBatchMove = class(TComponent)
55	private
56	FDestination: TIBTable;
57	FSource: TIBCustomDataSet;
58	FMode: TBatchMode;
59	FAbortOnKeyViol: Boolean;
60	FAbortOnProblem: Boolean;
61	FTransliterate: Boolean;
62	FRecordCount: Longint;
63	FMovedCount: Longint;
64	FKeyViolCount: Longint;
65	FProblemCount: Longint;
66	FChangedCount: Longint;
67	FMappings: TStrings;
68	FKeyViolTableName: TFileName;
69	FProblemTableName: TFileName;
70	FChangedTableName: TFileName;
71	FCommitCount: Integer;
72	procedure SetMappings(Value: TStrings);
73	procedure SetSource(Value: TIBCustomDataSet);
74	procedure InternalExecute (BatchMode: TBatchMode; FieldCount: Word);
75	protected
76	procedure Notification(AComponent: TComponent;
77	Operation: TOperation); override;
78	public
79	constructor Create(AOwner: TComponent); override;
80	destructor Destroy; override;
81	procedure Execute;
82	public
83	property ChangedCount: Longint read FChangedCount;
84	property KeyViolCount: Longint read FKeyViolCount;
85	property MovedCount: Longint read FMovedCount;
86	property ProblemCount: Longint read FProblemCount;
87	published
88	property AbortOnKeyViol: Boolean read FAbortOnKeyViol write FAbortOnKeyViol
89	default True;
90	property AbortOnProblem: Boolean read FAbortOnProblem write FAbortOnProblem
91	default True;
92	property CommitCount: Integer read FCommitCount write FCommitCount default 0;
93	property ChangedTableName: TFileName read FChangedTableName write FChangedTableName;
94	property Destination: TIBTable read FDestination write FDestination;
95	property KeyViolTableName: TFileName read FKeyViolTableName write FKeyViolTableName;
96	property Mappings: TStrings read FMappings write SetMappings;
97	property Mode: TBatchMode read FMode write FMode default batAppend;
98	property ProblemTableName: TFileName read FProblemTableName write FProblemTableName;
99	property RecordCount: Longint read FRecordCount write FRecordCount default 0;
100	property Source: TIBCustomDataSet read FSource write SetSource;
101	property Transliterate: Boolean read FTransliterate write FTransliterate
102	default True;
103	end;
104
105	implementation
106
107	uses FBMessages;
108
109	{ TIBBatchMove }
110
111	constructor TIBBatchMove.Create(AOwner: TComponent);
112	begin
113	inherited Create(AOwner);
114	FAbortOnKeyViol := True;
115	FAbortOnProblem := True;
116	FTransliterate := True;
117	FMappings := TStringList.Create;
118	end;
119
120	destructor TIBBatchMove.Destroy;
121	begin
122	if FMappings <> nil then
123	FMappings.Free;
124	inherited Destroy;
125	end;
126
127	procedure TIBBatchMove.Execute;
128	type
129	TFieldMap = array of Word;
130	var
131	SourceActive, DestinationActive: Boolean;
132	BatchMode: TBatchMode;
133	I: Integer;
134	FieldCount: Word;
135	FieldMap: TFieldMap;
136	DestName, SourceName: string;
137
138	procedure GetMappingNames;
139	var
140	P: Integer;
141	Mapping: string;
142	begin
143	Mapping := FMappings[I];
144	P := Pos('=', Mapping); {MBCS OK}
145	if P > 0 then
146	begin
147	DestName := Copy(Mapping, 1, P - 1);
148	SourceName := Copy(Mapping, P + 1, 255);
149	end
150	else begin
151	DestName := Mapping;
152	SourceName := Mapping;
153	end;
154	end;
155
156	begin
157	if (Destination = nil) or (Source = nil) or (Destination = Source) then
158	IBError(ibxeInvalidBatchMove, [nil]);
159	SourceActive := Source.Active;
160	DestinationActive := Destination.Active;
161	FieldCount := 0;
162	FieldMap := nil;
163	try
164	Source.DisableControls;
165	Destination.DisableControls;
166	Source.Open;
167	Source.CheckBrowseMode;
168	Source.UpdateCursorPos;
169	BatchMode := FMode;
170	if BatchMode = batCopy then
171	begin
172	Destination.Close;
173	if FMappings.Count = 0 then
174	Destination.FieldDefs := Source.FieldDefs
175	else
176	begin
177	Destination.FieldDefs.Clear;
178	for I := 0 to FMappings.Count - 1 do
179	begin
180	GetMappingNames;
181	with Source.FieldDefs.Find(SourceName) do
182	Destination.FieldDefs.Add(DestName, DataType, Size, Required);
183	end;
184	end;
185	Destination.IndexDefs.Clear;
186	Destination.CreateTable;
187	BatchMode := batAppend;
188	end;
189	Destination.Open;
190	Destination.CheckBrowseMode;
191	if FMappings.Count <> 0 then
192	begin
193	FieldCount := Destination.FieldDefs.Count;
194	SetLength(FieldMap, FieldCount);
195	for I := 0 to FMappings.Count - 1 do
196	begin
197	GetMappingNames;
198	FieldMap[Destination.FieldDefs.Find(DestName).FieldNo-1] :=
199	Source.FieldDefs.Find(SourceName).FieldNo;
200	end;
201	end;
202	if FRecordCount > 0 then
203	begin
204	Source.UpdateCursorPos;
205	FMovedCount := FRecordCount;
206	end else
207	begin
208	FMovedCount := MaxLongint;
209	end;
210	Source.CursorPosChanged;
211	try
212	InternalExecute (BatchMode, FieldCount);
213	finally
214	if DestinationActive then Destination.First;
215	end;
216	finally
217	if not DestinationActive then
218	Destination.Close;
219	if not SourceActive then
220	Source.Close;
221	Destination.EnableControls;
222	Source.EnableControls;
223	end;
224	end;
225
226	procedure TIBBatchMove.Notification(AComponent: TComponent;
227	Operation: TOperation);
228	begin
229	inherited Notification(AComponent, Operation);
230	if Operation = opRemove then
231	begin
232	if Destination = AComponent then
233	Destination := nil;
234	if Source = AComponent then
235	Source := nil;
236	end;
237	end;
238
239	procedure TIBBatchMove.SetMappings(Value: TStrings);
240	begin
241	FMappings.Assign(Value);
242	end;
243
244	procedure TIBBatchMove.SetSource(Value: TIBCustomDataSet);
245	begin
246	FSource := Value;
247	if Value <> nil then
248	Value.FreeNotification(Self);
249	end;
250
251
252	procedure TIBBatchMove.InternalExecute (BatchMode: TBatchMode; FieldCount: Word);
253	begin
254
255	end;
256
257	end.