ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/runtime/IBBatchMove.pas
Revision: 17
Committed: Sat Dec 28 19:22:24 2013 UTC (6 years, 6 months ago) by tony
File size: 8822 byte(s)
Log Message:
Committing updates for Release R1-0-5
Line File contents
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 }
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, {Graphics,} Classes, Controls, 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 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.