Author: Pieter Valentijn
Incapsulating a collection in a TDataset decendant. Enabling to save and load
diferent datasets in loading and saving component resources.
Answer:
I have writen a TDataset descendant that allows a collection to be set as property
so it will do the deletes inserts and updates for you with a little help from the
Data aware controls in delphi.
I made an example that saves some master detail data .
In my example i'll show you how i use the dataset in design time so i can set the
fields displaylength and it's displayLabel
For those cracks that do not need an example here's the compleet code of the
object.
For those who do just download the sample .
And of course do not forget to vote or leave a message :) ..
Greatings all and keep up the good work.
1 unit CollectionDataSet;
2
3 interface
4
5 uses
6 DB, Classes, typinfo, dialogs;
7
8 type
9 PRecInfo = ^TRecInfo;
10 TRecInfo = packed record
11 Bookmark: Integer;
12 BookmarkFlag: TBookmarkFlag;
13 end;
14
15 { TCollectionDataSet }
16
17 TCollectionDataSet = class(TDataSet)
18 private
19 FRecBufSize: Integer;
20 FRecInfoOfs: Integer;
21 FCurRec: Integer;
22 FFileName: string;
23 FLastBookmark: Integer;
24 FCollection: TCollection;
25 FCollectionCount: Integer;
26 procedure SetCollection(const Value: TCollection);
27 protected
28 function AllocRecordBuffer: PChar; override;
29 procedure FreeRecordBuffer(var Buffer: PChar); override;
30 procedure GetBookmarkData(Buffer: PChar; Data: Pointer); override;
31 function GetBookmarkFlag(Buffer: PChar): TBookmarkFlag; override;
32 function GetRecord(Buffer: PChar; GetMode: TGetMode; DoCheck: Boolean):
33 TGetResult; override;
34 function GetRecordSize: Word; override;
35 procedure InternalAddRecord(Buffer: Pointer; Append: Boolean); override;
36 procedure InternalClose; override;
37 procedure InternalCancel; override;
38 procedure InternalDelete; override;
39 procedure InternalFirst; override;
40 procedure InternalGotoBookmark(Bookmark: Pointer); override;
41 procedure InternalHandleException; override;
42 procedure InternalInitFieldDefs; override;
43 procedure InternalInitRecord(Buffer: PChar); override;
44 procedure InternalLast; override;
45 procedure InternalOpen; override;
46 procedure InternalPost; override;
47 procedure InternalSetToRecord(Buffer: PChar); override;
48 function IsCursorOpen: Boolean; override;
49 procedure SetBookmarkFlag(Buffer: PChar; Value: TBookmarkFlag); override;
50 procedure SetBookmarkData(Buffer: PChar; Data: Pointer); override;
51 procedure SetFieldData(Field: TField; Buffer: Pointer); override;
52 function GetRecordCount: Integer; override;
53 function GetRecNo: Integer; override;
54 procedure SetRecNo(Value: Integer); override;
55 public
56 function GetFieldData(Field: TField; Buffer: Pointer): Boolean; override;
57 property Collection: TCollection read FCollection write SetCollection;
58 published
59 property FileName: string read FFileName write FFileName;
60 property Active;
61 property AutoCalcFields;
62 property BeforeOpen;
63 property AfterOpen;
64 property BeforeClose;
65 property AfterClose;
66 property BeforeInsert;
67 property AfterInsert;
68 property BeforeEdit;
69 property AfterEdit;
70 property BeforePost;
71 property AfterPost;
72 property BeforeCancel;
73 property AfterCancel;
74 property BeforeDelete;
75 property AfterDelete;
76 property BeforeScroll;
77 property AfterScroll;
78 property BeforeRefresh;
79 property AfterRefresh;
80 property OnCalcFields;
81 property OnDeleteError;
82 property OnEditError;
83 property OnFilterRecord;
84 property OnNewRecord;
85 property OnPostError;
86
87 end;
88
89 procedure register;
90
91 implementation
92
93 uses Windows, SysUtils, Forms;
94
95 { TCollectionDataSet }
96
97 procedure TCollectionDataSet.InternalOpen;
98
99 begin
100 if Collection = nil then
101 raise EDatabaseError.Create('Collection is niet gevult !');
102
103 FCurRec := -1;
104
105 FCollectionCount := Collection.Count;
106 FLastBookmark := Collection.Count;
107 FRecInfoOfs := SizeOf(Integer);
108
109 FRecBufSize := SizeOf(TRecInfo) + FRecInfoOfs;
110 BookmarkSize := SizeOf(Integer);
111
112 InternalInitFieldDefs;
113
114 if DefaultFields then
115 CreateFields;
116
117 BindFields(True);
118 end;
119
120 procedure TCollectionDataSet.InternalClose;
121 begin
122
123 if DefaultFields then
124 DestroyFields;
125 FLastBookmark := 0;
126 FCurRec := -1;
127 end;
128
129 function TCollectionDataSet.IsCursorOpen: Boolean;
130 begin
131 Result := Assigned(collection);
132 end;
133
134 procedure TCollectionDataSet.InternalInitFieldDefs;
135 var
136 PropList: PPropList;
137 PropCount: Integer;
138 ClassTypeInfo: PTypeInfo;
139 ClassTypeData: PTypeData;
140 i: integer;
141 begin
142 FieldDefs.Clear;
143 if Collection = nil then
144 raise EInvalidPointer.create('Collection is nil');
145 ClassTypeInfo := Collection.ItemClass.ClassInfo;
146 ClassTypeData := GetTypeData(ClassTypeInfo);
147 PropCount := ClassTypeData.PropCount - 1;
148 // reserveer geheugen
149 GetMem(PropList, SizeOf(PPropInfo) * ClassTypeData.PropCount);
150 // Error trap
151 try
152 // Vul de prop list
153 GetPropList(Collection.ItemClass.ClassInfo, tkAny, PropList);
154 for i := 0 to PropCount do
155 begin
156 try
157 case PropList[i]^.PropType^.Kind of
158 tkString, tkLString,
159 tkWString, tkWChar,
160 tkChar:
161 begin
162 FieldDefs.Add(PropList[i]^.Name, ftString, 255, False);
163 end;
164
165 tkInteger,
166 tkEnumeration:
167 begin
168 FieldDefs.Add(PropList[i]^.Name, ftInteger, 0, False);
169 end;
170 tkFloat:
171 begin
172 FieldDefs.Add(PropList[i]^.Name, ftFloat, 0, False);
173 end;
174 tkClass:
175 begin
176 end;
177 tkArray:
178 begin
179 end;
180 end; // end case
181 except
182 on e: Exception do
183
184 end;
185
186 end;
187 finally
188 FreeMem(PropList, SizeOf(PPropInfo) * ClassTypeData.PropCount);
189 end;
190
191 end;
192
193 procedure TCollectionDataSet.InternalHandleException;
194 begin
195 Application.HandleException(Self);
196 end;
197
198 procedure TCollectionDataSet.InternalGotoBookmark(Bookmark: Pointer);
199 var
200 Index: Integer;
201 begin
202 Index := PInteger(Bookmark)^ - 1;
203 if Index > -1 then
204 FCurRec := Index
205 else
206 DatabaseError('Bookmark not found');
207 end;
208
209 procedure TCollectionDataSet.InternalSetToRecord(Buffer: PChar);
210 begin
211 InternalGotoBookmark(@PRecInfo(Buffer + FRecInfoOfs).Bookmark);
212 end;
213
214 function TCollectionDataSet.GetBookmarkFlag(Buffer: PChar): TBookmarkFlag;
215 begin
216 Result := PRecInfo(Buffer + FRecInfoOfs).BookmarkFlag;
217 end;
218
219 procedure TCollectionDataSet.SetBookmarkFlag(Buffer: PChar; Value: TBookmarkFlag);
220 begin
221 PRecInfo(Buffer + FRecInfoOfs).BookmarkFlag := Value;
222 end;
223
224 procedure TCollectionDataSet.GetBookmarkData(Buffer: PChar; Data: Pointer);
225 begin
226 PInteger(Data)^ := PRecInfo(Buffer + FRecInfoOfs).Bookmark;
227 end;
228
229 procedure TCollectionDataSet.SetBookmarkData(Buffer: PChar; Data: Pointer);
230 begin
231 PRecInfo(Buffer + FRecInfoOfs).Bookmark := PInteger(Data)^;
232 end;
233
234 function TCollectionDataSet.GetRecordSize: Word;
235 begin
236 Result := SizeOf(Integer); //MaxStrLen;
237 end;
238
239 function TCollectionDataSet.AllocRecordBuffer: PChar;
240 begin
241 GetMem(Result, FRecBufSize);
242 end;
243
244 procedure TCollectionDataSet.FreeRecordBuffer(var Buffer: PChar);
245 begin
246 FreeMem(Buffer, FRecBufSize);
247 end;
248
249 function TCollectionDataSet.GetRecord(Buffer: PChar; GetMode: TGetMode;
250 DoCheck: Boolean): TGetResult;
251 begin
252 if Collection.Count < 1 then
253 Result := grEOF
254 else
255 begin
256 Result := grOK;
257 case GetMode of
258 gmNext:
259 if FCurRec >= RecordCount - 1 then
260 Result := grEOF
261 else
262 Inc(FCurRec);
263 gmPrior:
264 if FCurRec <= 0 then
265 Result := grBOF
266 else
267 Dec(FCurRec);
268 gmCurrent:
269 if (FCurRec < 0) or (FCurRec >= RecordCount) then
270 Result := grError;
271 end;
272 if Result = grOK then
273 begin
274 PInteger(Buffer)^ := Integer(FCollection.Items[FCurRec]);
275 with PRecInfo(Buffer + FRecInfoOfs)^ do
276 begin
277 BookmarkFlag := bfCurrent;
278 Bookmark := FCurRec + 1;
279 end;
280 end
281 else if (Result = grError) and DoCheck then
282 DatabaseError('No Records');
283 end;
284 end;
285
286 procedure TCollectionDataSet.InternalInitRecord(Buffer: PChar);
287 begin
288 PInteger(Buffer)^ := Integer(FCollection.Add);
289 end;
290
291 function TCollectionDataSet.GetFieldData(Field: TField; Buffer: Pointer): Boolean;
292
293 var
294 Apropinfo: PPropinfo;
295 AString: string;
296 AInteger: Integer;
297 AFloat: Double;
298 AItem: TCollectionItem;
299 begin
300 Result := False;
301 if Collection.Count = 0 then
302 exit;
303 AItem := TCollectionItem(PInteger(ActiveBuffer)^);
304 Apropinfo := typinfo.GetPropInfo(AItem, Field.FullName);
305 case Apropinfo.PropType^.Kind of
306 tkString, tkLString,
307 tkWString, tkWChar,
308 tkChar:
309 begin
310 AString := GetStrProp(AItem, Apropinfo);
311 StrLCopy(Buffer, PChar(AString), Length(AString));
312 Result := PChar(Buffer)^ <> #0;
313 end;
314
315 tkInteger,
316 tkEnumeration:
317 begin
318 AInteger := GetOrdProp(AItem, Apropinfo);
319 PInteger(Buffer)^ := AInteger;
320 Result := true;
321 end;
322 tkFloat:
323 begin
324 AFloat := GetFloatProp(AItem, Apropinfo);
325 PDouble(Buffer)^ := AFloat;
326 Result := true;
327 end;
328 end; // end case
329 end;
330
331 procedure TCollectionDataSet.SetFieldData(Field: TField; Buffer: Pointer);
332 var
333 Apropinfo: PPropinfo;
334 AString: string;
335 AInteger: Integer;
336 AFloat: Double;
337 AItem: TCollectionItem;
338 begin
339 AItem := TCollectionItem(PInteger(ActiveBuffer)^);
340 Apropinfo := typinfo.GetPropInfo(AItem, Field.FullName);
341 case Apropinfo.PropType^.Kind of
342 tkString, tkLString,
343 tkWString, tkWChar,
344 tkChar:
345 begin
346 AString := PChar(Buffer);
347 SetStrProp(AItem, Apropinfo, AString);
348 end;
349
350 tkInteger,
351 tkEnumeration:
352 begin
353 AInteger := 0;
354 if Buffer <> nil then
355 AInteger := PInteger(Buffer)^;
356 SetOrdProp(AItem, Apropinfo, AInteger);
357 end;
358 tkFloat:
359 begin
360
361 AFloat := 0;
362 if Buffer <> nil then
363 AFloat := PDouble(Buffer)^;
364 SetFloatProp(AItem, Apropinfo, AFloat);
365 end;
366 end; // end case
367
368 DataEvent(deFieldChange, Longint(Field));
369 end;
370
371 procedure TCollectionDataSet.InternalFirst;
372 begin
373 FCurRec := -1;
374 end;
375
376 procedure TCollectionDataSet.InternalLast;
377 begin
378 FCurRec := FCollectionCount;
379 end;
380
381 procedure TCollectionDataSet.InternalPost;
382 begin
383 if State = dsinsert then
384 begin
385 Inc(FCollectionCount);
386 Inc(FLastBookmark);
387 if FCurRec <> -1 then
388 TCollectionItem(PInteger(ActiveBuffer)^).Index := FCurRec;
389 end;
390
391 end;
392
393 procedure TCollectionDataSet.InternalAddRecord(Buffer: Pointer; Append: Boolean);
394 begin
395 Inc(FLastBookmark);
396 if Append then
397 InternalLast;
398 Inc(FCollectionCount);
399
400 end;
401
402 procedure TCollectionDataSet.InternalDelete;
403 begin
404 Collection.Delete(FCurRec);
405 Dec(FCollectionCount);
406 if FCurRec >= Collection.Count then
407 Dec(FCurRec);
408 end;
409
410 function TCollectionDataSet.GetRecordCount: Longint;
411 begin
412 Result := FCollectionCount;
413 end;
414
415 function TCollectionDataSet.GetRecNo: Longint;
416 begin
417 UpdateCursorPos;
418 if (FCurRec <= -1) and (RecordCount > 0) then
419 Result := 0
420 else
421 Result := FCurRec + 1;
422 end;
423
424 procedure TCollectionDataSet.SetRecNo(Value: Integer);
425 begin
426 if (Value >= 0) and (Value < FCollectionCount) then
427 begin
428 FCurRec := Value - 1;
429 Resync([]);
430 end;
431 end;
432
433 procedure TCollectionDataSet.SetCollection(const Value: TCollection);
434 begin
435 FCollection := Value;
436 end;
437
438 procedure TCollectionDataSet.InternalCancel;
439 begin
440 Collection.Delete(Collection.Count - 1);
441 end;
442
443 end.
|
