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                                                 }
{                                                                        }
{************************************************************************}

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
    FIBLoaded: Boolean;
    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 IBIntf;

{ TIBBatchMove }

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

destructor TIBBatchMove.Destroy;
begin
  if FIBLoaded 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:	31
Committed:	Tue Jul 14 15:31:25 2015 UTC (9 years, 4 months ago) by tony
Content type:	text/x-pascal
File size:	8801 byte(s)
Log Message:	Committing updates for Release R1-3-0
#	User	Rev	Content
1	tony	17	{************************************************************************}
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 }
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	tony	31	SysUtils, Classes, Db,
47	tony	17	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			FIBLoaded: Boolean;
57			FDestination: TIBTable;
58			FSource: TIBCustomDataSet;
59			FMode: TBatchMode;
60			FAbortOnKeyViol: Boolean;
61			FAbortOnProblem: Boolean;
62			FTransliterate: Boolean;
63			FRecordCount: Longint;
64			FMovedCount: Longint;
65			FKeyViolCount: Longint;
66			FProblemCount: Longint;
67			FChangedCount: Longint;
68			FMappings: TStrings;
69			FKeyViolTableName: TFileName;
70			FProblemTableName: TFileName;
71			FChangedTableName: TFileName;
72			FCommitCount: Integer;
73			procedure SetMappings(Value: TStrings);
74			procedure SetSource(Value: TIBCustomDataSet);
75			procedure InternalExecute (BatchMode: TBatchMode; FieldCount: Word);
76			protected
77			procedure Notification(AComponent: TComponent;
78			Operation: TOperation); override;
79			public
80			constructor Create(AOwner: TComponent); override;
81			destructor Destroy; override;
82			procedure Execute;
83			public
84			property ChangedCount: Longint read FChangedCount;
85			property KeyViolCount: Longint read FKeyViolCount;
86			property MovedCount: Longint read FMovedCount;
87			property ProblemCount: Longint read FProblemCount;
88			published
89			property AbortOnKeyViol: Boolean read FAbortOnKeyViol write FAbortOnKeyViol
90			default True;
91			property AbortOnProblem: Boolean read FAbortOnProblem write FAbortOnProblem
92			default True;
93			property CommitCount: Integer read FCommitCount write FCommitCount default 0;
94			property ChangedTableName: TFileName read FChangedTableName write FChangedTableName;
95			property Destination: TIBTable read FDestination write FDestination;
96			property KeyViolTableName: TFileName read FKeyViolTableName write FKeyViolTableName;
97			property Mappings: TStrings read FMappings write SetMappings;
98			property Mode: TBatchMode read FMode write FMode default batAppend;
99			property ProblemTableName: TFileName read FProblemTableName write FProblemTableName;
100			property RecordCount: Longint read FRecordCount write FRecordCount default 0;
101			property Source: TIBCustomDataSet read FSource write SetSource;
102			property Transliterate: Boolean read FTransliterate write FTransliterate
103			default True;
104			end;
105
106			implementation
107
108			uses IBIntf;
109
110			{ TIBBatchMove }
111
112			constructor TIBBatchMove.Create(AOwner: TComponent);
113			begin
114			inherited Create(AOwner);
115			FIBLoaded := False;
116			CheckIBLoaded;
117			FIBLoaded := True;
118			FAbortOnKeyViol := True;
119			FAbortOnProblem := True;
120			FTransliterate := True;
121			FMappings := TStringList.Create;
122			end;
123
124			destructor TIBBatchMove.Destroy;
125			begin
126			if FIBLoaded then
127			FMappings.Free;
128			inherited Destroy;
129			end;
130
131			procedure TIBBatchMove.Execute;
132			type
133			TFieldMap = array of Word;
134			var
135			SourceActive, DestinationActive: Boolean;
136			BatchMode: TBatchMode;
137			I: Integer;
138			FieldCount: Word;
139			FieldMap: TFieldMap;
140			DestName, SourceName: string;
141
142			procedure GetMappingNames;
143			var
144			P: Integer;
145			Mapping: string;
146			begin
147			Mapping := FMappings[I];
148			P := Pos('=', Mapping); {MBCS OK}
149			if P > 0 then
150			begin
151			DestName := Copy(Mapping, 1, P - 1);
152			SourceName := Copy(Mapping, P + 1, 255);
153			end
154			else begin
155			DestName := Mapping;
156			SourceName := Mapping;
157			end;
158			end;
159
160			begin
161			if (Destination = nil) or (Source = nil) or (Destination = Source) then
162			IBError(ibxeInvalidBatchMove, [nil]);
163			SourceActive := Source.Active;
164			DestinationActive := Destination.Active;
165			FieldCount := 0;
166			FieldMap := nil;
167			try
168			Source.DisableControls;
169			Destination.DisableControls;
170			Source.Open;
171			Source.CheckBrowseMode;
172			Source.UpdateCursorPos;
173			BatchMode := FMode;
174			if BatchMode = batCopy then
175			begin
176			Destination.Close;
177			if FMappings.Count = 0 then
178			Destination.FieldDefs := Source.FieldDefs
179			else
180			begin
181			Destination.FieldDefs.Clear;
182			for I := 0 to FMappings.Count - 1 do
183			begin
184			GetMappingNames;
185			with Source.FieldDefs.Find(SourceName) do
186			Destination.FieldDefs.Add(DestName, DataType, Size, Required);
187			end;
188			end;
189			Destination.IndexDefs.Clear;
190			Destination.CreateTable;
191			BatchMode := batAppend;
192			end;
193			Destination.Open;
194			Destination.CheckBrowseMode;
195			if FMappings.Count <> 0 then
196			begin
197			FieldCount := Destination.FieldDefs.Count;
198			SetLength(FieldMap, FieldCount);
199			for I := 0 to FMappings.Count - 1 do
200			begin
201			GetMappingNames;
202			FieldMap[Destination.FieldDefs.Find(DestName).FieldNo-1] :=
203			Source.FieldDefs.Find(SourceName).FieldNo;
204			end;
205			end;
206			if FRecordCount > 0 then
207			begin
208			Source.UpdateCursorPos;
209			FMovedCount := FRecordCount;
210			end else
211			begin
212			FMovedCount := MaxLongint;
213			end;
214			Source.CursorPosChanged;
215			try
216			InternalExecute (BatchMode, FieldCount);
217			finally
218			if DestinationActive then Destination.First;
219			end;
220			finally
221			if not DestinationActive then
222			Destination.Close;
223			if not SourceActive then
224			Source.Close;
225			Destination.EnableControls;
226			Source.EnableControls;
227			end;
228			end;
229
230			procedure TIBBatchMove.Notification(AComponent: TComponent;
231			Operation: TOperation);
232			begin
233			inherited Notification(AComponent, Operation);
234			if Operation = opRemove then
235			begin
236			if Destination = AComponent then
237			Destination := nil;
238			if Source = AComponent then
239			Source := nil;
240			end;
241			end;
242
243			procedure TIBBatchMove.SetMappings(Value: TStrings);
244			begin
245			FMappings.Assign(Value);
246			end;
247
248			procedure TIBBatchMove.SetSource(Value: TIBCustomDataSet);
249			begin
250			FSource := Value;
251			if Value <> nil then
252			Value.FreeNotification(Self);
253			end;
254
255
256			procedure TIBBatchMove.InternalExecute (BatchMode: TBatchMode; FieldCount: Word);
257			begin
258
259			end;
260
261			end.