Author: Tomas Rutkauskas
Has anyone out there attempted to use TCollection and TCollectionItem? What I am
trying to do is mimic what the Columns Editor does in the TDBGrid for the
TStringGrid component. This is the first time that I have made a component that
needs properties and sub-properties. I am not sure how to go about this.
Answer:
This one worked for me:
1 unit ggImgLst;
2
3 interface
4
5 uses
6 Windows, Messages, SysUtils, Classes, Graphics, Controls, Dialogs,
7 ExtCtrls, Dsgnintf; {, jpeg;}
8
9 type
10 TAboutProperty = class(TPropertyEditor)
11 private
12 protected
13 public
14 procedure Edit; override;
15 function GetAttributes: TPropertyAttributes; override;
16 function GetName: string; override;
17 function GetValue: string; override;
18 end;
19
20 TggImageListPropertyEditor = class(TPersistent);
21
22 TggImageListProperty = class(TClassProperty);
23
24 TggImageSizes = (ggSmall, ggMedium, ggLarge);
25 {TggImageSize = set of TggImageSizes;}
26
27 TggImage = class;
28 TggImageList = class;
29
30 TggImage = class(TCollectionItem)
31 private
32 FSize: TggImageSizes;
33 FPicture: TPicture;
34 FName: string;
35 function GetDisplayName: string; override;
36 procedure SetPicture(Value: TPicture);
37 public
38 constructor Create(Collection: TCollection); override;
39 destructor destroy; override;
40 published
41 property Size: TggImageSizes read FSize write FSize;
42 property Name: string read FName write FName;
43 property Picture: TPicture read FPicture write SetPicture;
44 end;
45
46 TggImageClass = class of TggImage;
47
48 TggImages = class(TCollection)
49 private
50 FggImageList: TggImageList;
51 FggImageListPropertyEditor: TggImageListPropertyEditor;
52 function GetImage(Index: Integer): TggImage;
53 procedure SetImage(Index: Integer; Value: TggImage);
54 protected
55 function GetOwner: TPersistent; override;
56 public
57 constructor create(ggImageList: TggImageList; ggImageClass: TggImageClass);
58 function Add: TggImage;
59 property ggImageList: TggImageList read FggImageList;
60 property Items[Index: Integer]: TggImage read GetImage write SetImage; default;
61 published
62 end;
63
64 TggImageList = class(TComponent)
65 private
66 FAbout: TAboutProperty;
67 FImages: TggImages;
68 procedure WriteImages(Writer: TWriter);
69 procedure ReadImages(Reader: TReader);
70 procedure SetImages(Value: TggImages);
71 protected
72 function CreateImages: Tggimages; dynamic;
73 procedure DefineProperties(Filer: TFiler); override;
74 public
75 constructor Create(AOwner: TComponent); override;
76 function GetImageNameList: TStringList;
77 function GetPicture(PictureName: string): TPicture;
78 published
79 property About: TAboutProperty read FAbout write FAbout;
80 property Images: TggImages read FImages write SetImages;
81 end;
82
83 procedure register;
84
85 implementation
86
87 uses
88 jpeg;
89
90 {ggImage}
91
92 constructor TggImage.Create(Collection: TCollection);
93 var
94 ggImageList: TggImageList;
95 begin
96 FPicture := TPicture.Create;
97 ggImageList := nil;
98 if assigned(Collection) and (Collection is TggImages) then
99 ggImageList := Tggimages(Collection).ggImageList;
100 if assigned(ggImageList) then
101 inherited Create(Collection);
102 end;
103
104 destructor TggImage.Destroy;
105 begin
106 FPicture.Free;
107 inherited Destroy;
108 end;
109
110 procedure TggImage.SetPicture(Value: TPicture);
111 begin
112 FPicture.Assign(Value);
113 end;
114
115 function TggImage.GetDisplayName: string;
116 begin
117 Result := Name;
118 if Result = '' then
119 Result := inherited GetDisplayName;
120 end;
121
122 {TggImages}
123
124 function TggImages.GetImage(Index: Integer): TggImage;
125 begin
126 Result := TggImage(inherited Items[Index]);
127 end;
128
129 procedure TggImages.SetImage(Index: Integer; Value: TggImage);
130 begin
131 Items[Index].Assign(Value);
132 end;
133
134 constructor TggImages.Create(ggImageList: TggImageList;
135 ggImageClass: TggImageClass);
136 begin
137 inherited Create(ggImageClass);
138 FggImageList := ggImageList;
139 FggImageListPropertyEditor := TggImageListPropertyEditor.Create;
140 end;
141
142 function TggImages.GetOwner: TPersistent;
143 begin
144 Result := FggImageList;
145 end;
146
147 function TggImages.Add: TggImage;
148 begin
149 Result := TggImage(inherited Add);
150 end;
151
152 {ggImageList}
153
154 procedure TggImageList.WriteImages(Writer: TWriter);
155 begin
156 Writer.WriteCollection(Images);
157 end;
158
159 procedure TggImageList.ReadImages(Reader: TReader);
160 begin
161 Images.Clear;
162 Reader.ReadValue;
163 Reader.ReadCollection(Images);
164 end;
165
166 procedure TggImageList.DefineProperties(Filer: TFiler);
167 begin
168 Filer.DefineProperty('ggImages', ReadImages, WriteImages, Filer.Ancestor < > nil);
169 end;
170
171 procedure TggImageList.SetImages(Value: TggImages);
172 begin
173 Images.Assign(Value);
174 end;
175
176 function TggImageList.CreateImages: TggImages;
177 begin
178 Result := TggImages.Create(Self, TggImage);
179 end;
180
181 function TggImageList.GetImageNameList: TStringList;
182 var
183 I: Integer;
184 begin
185 Result := TStringList.Create;
186 for I := 0 to Self.Images.Count - 1 do
187 Result.Add(Self.Images.Items[I].Name);
188 end;
189
190 function TggImageList.GetPicture(PictureName: string): TPicture;
191 var
192 I: Integer;
193 begin
194 I := 0;
195 Result := nil;
196 PictureName := uppercase(Picturename);
197 while I <= Self.Images.Count - 1 do
198 begin
199 if PictureName = uppercase(Self.Images.Items[I].Name) then
200 begin
201 Result := Self.Images.Items[I].Picture;
202 I := Self.Images.Count;
203 end
204 else
205 Inc(I);
206 end;
207 end;
208
209 constructor TggImageList.Create(AOwner: TComponent);
210 begin
211 inherited Create(AOwner);
212 FImages := CreateImages;
213 end;
214
215 {TAboutProperty}
216
217 procedure TAboutProperty.Edit;
218 begin
219 MessageBox(0, PChar('TggImageList component' + #13 + #13 + 'by Geurts Guido -
220 guido.geurts@advalvas.be '
221 PChar('The GuidoG utilities present...'), MB_OK);
222 end;
223
224 function TAboutProperty.GetAttributes: TPropertyAttributes;
225 begin
226 Result := [paDialog, paReadOnly];
227 end;
228
229 function TAboutProperty.GetName: string;
230 begin
231 Result := 'About';
232 end;
233
234 function TAboutProperty.GetValue: string;
235 begin
236 Result := GetStrValue;
237 end;
238
239 {Non class related procedures and functions:}
240
241 procedure register;
242 begin
243 RegisterComponents('GuidoG', [TggImageList]);
244 RegisterPropertyEditor(TypeInfo(TggImageListPropertyEditor), TGGImages,
245 'Images', TGGImageListProperty);
246 RegisterPropertyEditor(TypeInfo(TAboutProperty), TggImageList, 'About',
247 TAboutProperty);
248 end;
249
250 end.
|
