ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/runtime/IBBatchMove.pas
(Generate patch)

Comparing ibx/trunk/runtime/IBBatchMove.pas (file contents):
Revision 16 by tony, Sun Aug 5 18:28:19 2012 UTC vs.
Revision 17 by tony, Sat Dec 28 19:22:24 2013 UTC

# Line 1 | Line 1
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.
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.

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines