source: cprs/trunk/VA/VA508Accessibility/VA508ImageListLabelerPE.pas@ 1768

Last change on this file since 1768 was 829, checked in by Kevin Toppenberg, 14 years ago

Upgrade to version 27

File size: 10.7 KB
Line 
1unit VA508ImageListLabelerPE;
2
3interface
4
5uses
6 Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
7 Dialogs, ComCtrls, ExtCtrls, ColnEdit, ToolWnds, ImgList, DesignIntf, TypInfo,
8 DesignEditors, VA508ImageListLabeler, VA508MSAASupport, ToolsAPI, StdCtrls, Buttons, Menus;
9
10const
11 VA508_CUSTOM_REDRAW_IMAGES = WM_USER + 123;
12
13type
14 TVA508ImageListReceiver = procedure(lvItem: TListItem; item: TVA508ImageListLabel) of object;
15
16 TfrmImageListEditor = class(TCollectionEditor)
17 imgTemp16: TImageList;
18 imgTemp24: TImageList;
19 imgTemp32: TImageList;
20 private
21 FRedrawImages: boolean;
22 FSize: integer;
23 FBitMap1: TBitMap;
24 FBitMap2: TBitMap;
25 FBMRect: TRect;
26 FOldOnChange: TNotifyEvent;
27 FOnChangeRedirected: boolean;
28 procedure ImageDataChanged(Sender: TObject);
29 procedure IterateItems(Receiver: TVA508ImageListReceiver);
30 procedure RedrawImages(var Msg); message VA508_CUSTOM_REDRAW_IMAGES;
31 procedure GetSize;
32 procedure UpdateImages(lvItem: TListItem; item: TVA508ImageListLabel);
33 function GetImageList: TImageList;
34 protected
35 procedure ItemChange(Sender: TObject; Item: TListItem);
36 public
37 constructor Create(AOwner: TComponent); override;
38 destructor Destroy; override;
39 end;
40
41 TVA508ImageListItemsProperty = class(TCollectionProperty)
42 public
43 function GetAttributes: TPropertyAttributes; override;
44 function GetEditorClass: TCollectionEditorClass; override;
45 end;
46
47 TVA508ImageListComponentEditor = class(TComponentEditor)
48 public
49 procedure Edit; override;
50 procedure ExecuteVerb(Index: Integer); override;
51 function GetVerb(Index: Integer): string; override;
52 function GetVerbCount: Integer; override;
53 end;
54
55 TVA508ImageListComponentProperty = class(TComponentProperty)
56 private
57 FProc: TGetStrProc;
58 procedure FilterValues(const S: string);
59 public
60 procedure GetValues(Proc: TGetStrProc); override;
61 function GetValue: string; override;
62 procedure SetValue(const Value: string); override;
63 end;
64
65 TVA508LabelerImageListProperty = class(TComponentProperty)
66 public
67 function GetAttributes: TPropertyAttributes; override;
68 end;
69
70 TVA508LabelerRemoteLabelerProperty = class(TComponentProperty)
71 private
72 FProc: TGetStrProc;
73 procedure FilterValues(const S: string);
74 public
75 procedure GetValues(Proc: TGetStrProc); override;
76 end;
77
78procedure Register;
79
80implementation
81
82{$R *.dfm}
83
84procedure Register;
85begin
86 RegisterPropertyEditor(TypeInfo(TVA508ImageListLabels), TVA508ImageListLabeler, 'Labels', TVA508ImageListItemsProperty);
87 RegisterPropertyEditor(TypeInfo(TVA508ImageListLabeler), TVA508ImageListLabeler, 'RemoteLabeler', TVA508LabelerRemoteLabelerProperty);
88 RegisterPropertyEditor(TypeInfo(TCustomImageList), TVA508ImageListLabeler, 'ImageList', TVA508LabelerImageListProperty);
89 RegisterPropertyEditor(TypeInfo(TComponent), TVA508ImageListComponent, 'Component', TVA508ImageListComponentProperty);
90 RegisterComponentEditor(TVA508ImageListLabeler, TVA508ImageListComponentEditor);
91end;
92
93const
94 GSIZE_SMALL = 16;
95 GSIZE_MED = 24;
96 GSIZE_LARGE = 32;
97
98type
99 TVA508AccessImageListLabeler = class(TVA508ImageListLabeler);
100
101
102constructor TfrmImageListEditor.Create(AOwner: TComponent);
103begin
104 inherited Create(AOwner);
105// this works because refresh of images in parent class destroys and rebuilds list
106 ListView1.OnInsert := ItemChange;
107 ListView1.OnDeletion := ItemChange;
108end;
109
110{ TVA508GraphicsProperty }
111
112function TVA508ImageListItemsProperty.GetAttributes: TPropertyAttributes;
113var
114 comp: TVA508ImageListLabeler;
115begin
116 comp := TVA508ImageListLabeler(GetComponent(0));
117 if assigned(comp) and assigned(comp.RemoteLabeler) then
118 Result := [paReadOnly, paDisplayReadOnly, paAutoUpdate]
119 else
120 Result := inherited GetAttributes + [paAutoUpdate];
121end;
122
123function TVA508ImageListItemsProperty.GetEditorClass: TCollectionEditorClass;
124begin
125 Result := TfrmImageListEditor;
126end;
127
128destructor TfrmImageListEditor.Destroy;
129begin
130 if FOnChangeRedirected then
131 begin
132 TVA508AccessImageListLabeler(Component).OnChange := FOldOnChange;
133 FOnChangeRedirected := FALSE;
134 end;
135 inherited;
136end;
137
138procedure TfrmImageListEditor.ImageDataChanged(Sender: TObject);
139begin
140 ItemChange(Sender, nil);
141end;
142
143procedure TfrmImageListEditor.ItemChange(Sender: TObject;
144 Item: TListItem);
145var
146 Msg: TMsg;
147begin
148 FRedrawImages := TRUE;
149 if not PeekMessage(Msg, Handle, VA508_CUSTOM_REDRAW_IMAGES, VA508_CUSTOM_REDRAW_IMAGES, PM_NOREMOVE) then
150 PostMessage(Handle, VA508_CUSTOM_REDRAW_IMAGES, 0, 0);
151end;
152
153procedure TfrmImageListEditor.IterateItems(
154 Receiver: TVA508ImageListReceiver);
155var
156 i: integer;
157 item: TVA508ImageListLabel;
158 lvItem: TListItem;
159
160begin
161 if assigned(Receiver) then
162 begin
163 ListView1.items.BeginUpdate;
164 try
165 for i := 0 to ListView1.Items.Count - 1 do
166 begin
167 lvItem := ListView1.items[i];
168 item := TVA508ImageListLabels(Collection).Items[i];
169 if assigned(item) then
170 Receiver(lvItem, item);
171 end;
172 finally
173 ListView1.items.EndUpdate;
174 end;
175 end;
176end;
177
178function TfrmImageListEditor.GetImageList: TImageList;
179begin
180 case FSize of
181 GSIZE_SMALL: Result := imgTemp16;
182 GSIZE_MED: Result := imgTemp24;
183 GSIZE_LARGE: Result := imgTemp32;
184 else Result := nil;
185 end;
186end;
187
188procedure TfrmImageListEditor.GetSize;
189var
190 imgSize: integer;
191 imageList: TCustomImageList;
192begin
193 imageList := TVA508AccessImageListLabeler(Component).ImageList;
194 if assigned(ImageList) then
195 begin
196 imgSize := ImageList.Height;
197 if imgSize < ImageList.Width then
198 imgSize := ImageList.Width;
199 end
200 else
201 imgSize := 0;
202 if FSize < imgSize then
203 FSize := imgSize;
204end;
205
206procedure TfrmImageListEditor.RedrawImages(var Msg);
207var
208 i, BeforeSize: integer;
209 imgList: TImageList;
210
211begin
212 if FRedrawImages then
213 begin
214 FRedrawImages := FALSE;
215 ListView1.items.BeginUpdate;
216 try
217 if not FOnChangeRedirected then
218 begin
219 FOldOnChange := TVA508AccessImageListLabeler(Component).OnChange;
220 TVA508AccessImageListLabeler(Component).OnChange := ImageDataChanged;
221 FOnChangeRedirected := TRUE;
222 end;
223
224 BeforeSize := FSize;
225 FSize := GSIZE_SMALL;
226
227 GetSize;
228 if FSize > GSIZE_MED then
229 FSize := GSIZE_LARGE
230 else if FSize > GSIZE_SMALL then
231 FSize := GSIZE_MED
232 else
233 FSize := GSIZE_SMALL;
234
235 if FSize <> BeforeSize then
236 ListView1.Columns[0].Width := FSize * 3;
237
238 imgList := GetImageList;
239 for I := imgList.Count - 1 downto 1 do
240 imgList.Delete(i);
241 ListView1.SmallImages := imgList;
242 ListView1.StateImages := imgList;
243
244 FBitmap1 := TBitMap.Create;
245 FBitmap2 := TBitMap.Create;
246 try
247 FBitmap1.Height := imgList.Height;
248 FBitmap1.Width := imgList.Width;
249 FBMRect.Left := 0;
250 FBMRect.Top := 0;
251 FBMRect.Right := FBitMap1.Width;
252 FBMRect.Bottom := FBitMap1.Height;
253
254 IterateItems(UpdateImages);
255 finally
256 FreeAndNil(FBitmap1);
257 FreeAndNil(FBitmap1);
258 end;
259 finally
260 ListView1.items.EndUpdate;
261 end;
262 end;
263end;
264
265procedure TfrmImageListEditor.UpdateImages(lvItem: TListItem;
266 item: TVA508ImageListLabel);
267var
268 imgLst: TImageList;
269 stretch: boolean;
270 ImageList: TCustomImageList;
271
272begin
273 ImageList := TVA508AccessImageListLabeler(Component).ImageList;
274 if assigned(ImageList) and (item.ImageIndex >= 0) then
275 begin
276 imgLst := GetImageList;
277 stretch := ((imgLst.Height <> ImageList.Height) or
278 (imgLst.Width <> ImageList.Width));
279 if stretch then
280 begin
281 ImageList.GetBitmap(item.ImageIndex, FBitMap2);
282 FBitmap1.Canvas.StretchDraw(FBMRect, FBitMap2);
283 end
284 else
285 ImageList.GetBitmap(item.ImageIndex, FBitMap1);
286
287 imgLst.Add(FBitMap1, nil);
288 lvitem.ImageIndex := imglst.Count-1;
289 FBitMap1.Canvas.FillRect(FBMRect);
290 if stretch then
291 FBitMap2.Canvas.FillRect(FBMRect);
292 end
293 else
294 lvitem.ImageIndex := 0;
295end;
296
297{ TVA508ImageListComponentEditor }
298
299procedure TVA508ImageListComponentEditor.Edit;
300begin
301 ShowCollectionEditorClass(Designer, TfrmImageListEditor, Component,
302 TVA508ImageListLabeler(Component).Labels, 'Images');
303end;
304
305procedure TVA508ImageListComponentEditor.ExecuteVerb(Index: Integer);
306begin
307 if Index = 0 then Edit
308 else inherited ExecuteVerb(Index);
309end;
310
311function TVA508ImageListComponentEditor.GetVerb(Index: Integer): string;
312begin
313 if Index = 0 then
314 Result := 'Edit Image List Labels...'
315 else
316 Result := inherited GetVerb(Index);
317end;
318
319function TVA508ImageListComponentEditor.GetVerbCount: Integer;
320begin
321 Result := 1;
322end;
323
324
325{ TVA508ImageListComponentProperty }
326
327procedure TVA508ImageListComponentProperty.FilterValues(const S: string);
328var
329 comp: TComponent;
330 i: integer;
331
332begin
333 comp := Designer.GetComponent(S);
334 if assigned(comp) then
335 begin
336 for i := low(VA508ImageListLabelerClasses) to high(VA508ImageListLabelerClasses) do
337 begin
338 if comp is VA508ImageListLabelerClasses[i] then
339 FProc(S + ' (' + comp.ClassName + ')');
340 end;
341 end;
342end;
343
344function TVA508ImageListComponentProperty.GetValue: string;
345var
346 comp: TComponent;
347
348begin
349 Result := inherited GetValue;
350 comp := Designer.GetComponent(Result);
351 if assigned(comp) then
352 Result := Result + ' (' + comp.ClassName + ')';
353end;
354
355procedure TVA508ImageListComponentProperty.GetValues(Proc: TGetStrProc);
356begin
357 FProc := Proc;
358 Designer.GetComponentNames(GetTypeData(GetPropType), FilterValues);
359end;
360
361procedure TVA508ImageListComponentProperty.SetValue(const Value: string);
362var
363 i: integer;
364 data: string;
365begin
366 data := Value;
367 i := pos(' (',data);
368 if i > 0 then
369 delete(data, i, MaxInt);
370 inherited SetValue(Data);
371end;
372
373
374{ TVA508LabelerImageListProperty }
375
376function TVA508LabelerImageListProperty.GetAttributes: TPropertyAttributes;
377var
378 comp: TVA508ImageListLabeler;
379begin
380 comp := TVA508ImageListLabeler(GetComponent(0));
381 if assigned(comp) and (not assigned(comp.RemoteLabeler)) then
382 Result := inherited GetAttributes
383 else
384 Result := [paReadOnly, paDisplayReadOnly, paAutoUpdate];
385end;
386
387
388{ TVA508LabelerRemoteLabelerProperty }
389
390procedure TVA508LabelerRemoteLabelerProperty.FilterValues(const S: string);
391begin
392 if pos('->', S) > 0 then
393 FProc(S);
394end;
395
396procedure TVA508LabelerRemoteLabelerProperty.GetValues(Proc: TGetStrProc);
397begin
398 FProc := Proc;
399 Designer.GetComponentNames(GetTypeData(GetPropType), FilterValues);
400end;
401
402end.
Note: See TracBrowser for help on using the repository browser.