source: cprs/branches/HealthSevak-CPRS/VA/VA508Accessibility/VA508ImageListLabeler.pas@ 1725

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

Upgrade to version 27

File size: 19.6 KB
Line 
1unit VA508ImageListLabeler;
2
3interface
4
5uses
6 Windows, Messages, SysUtils, Classes, Controls, ImgList, VAClasses, Graphics, ComCtrls,
7 Contnrs, Forms, oleacc2, VA508MSAASupport;
8
9type
10 TVA508ImageListLabeler = class;
11 TVA508ImageListLabels = class;
12
13 TVA508ImageListLabel = class(TCollectionItem)
14 private
15 FImageIndex: integer;
16 FCaption: string;
17 FOverlayIndex: integer;
18 procedure SetImageIndex(const Value: integer);
19 procedure Changed;
20 procedure SetCaption(const Value: string);
21 procedure SetOverlayIndex(const Value: integer);
22 protected
23 procedure Refresh;
24 function Labeler: TVA508ImageListLabeler;
25 public
26 constructor Create(Collection: TCollection); override;
27 destructor Destroy; override;
28 procedure Assign(Source: TPersistent); override;
29 published
30 property Caption: string read FCaption write SetCaption;
31 property ImageIndex: integer read FImageIndex write SetImageIndex;
32 property OverlayIndex: integer read FOverlayIndex write SetOverlayIndex;
33 end;
34
35 TVA508ImageListLabels = class(TCollection)
36 private
37 FOwner: TVA508ImageListLabeler;
38 FColumns: TStringList;
39 FImageData: TStrings;
40 FOverlayData: TStrings;
41 FBuildOverlayData: boolean;
42 protected
43 function GetAttrCount: Integer; override;
44 function GetAttr(Index: Integer): string; override;
45 function GetItemAttr(Index, ItemIndex: Integer): string; override;
46 function GetItem(Index: Integer): TVA508ImageListLabel;
47 procedure SetItem(Index: Integer; Value: TVA508ImageListLabel);
48 procedure Notify(Item: TCollectionItem; Action: TCollectionNotification); override;
49 procedure Update(Item: TCollectionItem); override;
50 function GetImageData: TStrings;
51 function GetOverlayData: TStrings;
52 procedure ResetData;
53 public
54 constructor Create(Owner: TVA508ImageListLabeler);
55 destructor Destroy; override;
56 function GetOwner: TPersistent; override;
57 function Add: TVA508ImageListLabel;
58 property Items[Index: Integer]: TVA508ImageListLabel read GetItem write SetItem; default;
59 end;
60
61 TVA508ImageListComponent = class(TCollectionItem)
62 private
63 FComponent: TWinControl;
64 FComponentNotifier: TVANotificationEventComponent;
65 procedure ComponentNotifyEvent(AComponent: TComponent; Operation: TOperation);
66 procedure SetComponent(const Value: TWinControl);
67 function Labeler: TVA508ImageListLabeler;
68 protected
69 function GetDisplayName: string; override;
70 public
71 destructor Destroy; override;
72 procedure Assign(Source: TPersistent); override;
73 function ImageListTypes: TVA508ImageListTypes;
74 published
75 property Component: TWinControl read FComponent write SetComponent;
76 end;
77
78 TVA508ImageListComponents = class(TCollection)
79 private
80 FOwner: TVA508ImageListLabeler;
81 protected
82 function GetItem(Index: Integer): TVA508ImageListComponent;
83 procedure SetItem(Index: Integer; Value: TVA508ImageListComponent);
84 procedure Notify(Item: TCollectionItem; Action: TCollectionNotification); override;
85 public
86 constructor Create(Owner: TVA508ImageListLabeler);
87 destructor Destroy; override;
88 function GetOwner: TPersistent; override;
89 function Add: TVA508ImageListComponent;
90 property Items[Index: Integer]: TVA508ImageListComponent read GetItem write SetItem; default;
91 end;
92
93 TVA508ImageListLabeler = class(TComponent)
94 private
95 FStartup: boolean;
96 FOldComponentList: TList;
97 FImageListChanging: boolean;
98 FImageListChanged: boolean;
99 FItemChange: boolean;
100 FOnChange: TNotifyEvent;
101 FChangeLink: TChangeLink;
102 FImageList: TCustomImageList;
103 FComponents: TVA508ImageListComponents;
104 FItems: TVA508ImageListLabels;
105 FRemoteLabeler: TVA508ImageListLabeler;
106 procedure SetImageList(const Value: TCustomImageList);
107 procedure SetRemoteLabeler(const Value: TVA508ImageListLabeler);
108 protected
109 procedure ImageIndexQuery(Sender: TObject; ImageIndex: integer;
110 ImageType: TVA508ImageListType; var ImageText: string);
111 procedure Loaded; override;
112 procedure Notification(AComponent: TComponent; Operation: TOperation); override;
113 procedure ImageListChange(Sender: TObject);
114 procedure ItemChanged;
115 procedure SaveChanges(Reregister: boolean);
116 property OnChange: TNotifyEvent read FOnChange write FOnChange;
117 public
118 constructor Create(AOwner: TComponent); override;
119 destructor Destroy; override;
120 procedure ComponentImageListChanged;
121 published
122 property Components: TVA508ImageListComponents read FComponents write FComponents;
123 property ImageList: TCustomImageList read FImageList write SetImageList;
124 property Labels: TVA508ImageListLabels read FItems write FItems;
125 property RemoteLabeler: TVA508ImageListLabeler read FRemoteLabeler write SetRemoteLabeler;
126 end;
127
128procedure Register;
129
130implementation
131
132uses VA508Classes, VA508AccessibilityRouter;
133
134procedure Register;
135begin
136 RegisterComponents('VA 508', [TVA508ImageListLabeler]);
137end;
138
139{ TVA508ImageListLabeler }
140
141procedure TVA508ImageListLabeler.ComponentImageListChanged;
142begin
143 SaveChanges(TRUE);
144end;
145
146constructor TVA508ImageListLabeler.Create(AOwner: TComponent);
147begin
148 inherited Create(AOwner);
149 FStartup := TRUE;
150 FOldComponentList := TList.Create;
151 FItems := TVA508ImageListLabels.Create(Self);
152 FComponents := TVA508ImageListComponents.Create(Self);
153 FChangeLink := TChangeLink.Create;
154 FChangeLink.OnChange := ImageListChange;
155 VA508ComponentCreationCheck(Self, AOwner, TRUE, TRUE);
156end;
157
158destructor TVA508ImageListLabeler.Destroy;
159begin
160 FItems.Clear;
161 FComponents.Clear;
162 SaveChanges(FALSE);
163 SetImageList(nil);
164 FreeAndNil(FItems);
165 FreeAndNil(FComponents);
166 FChangeLink.Free;
167 FreeAndNil(FOldComponentList);
168 inherited;
169end;
170
171procedure TVA508ImageListLabeler.ImageIndexQuery(Sender: TObject; ImageIndex: integer;
172 ImageType: TVA508ImageListType; var ImageText: string);
173var
174 list: TStrings;
175begin
176 if ImageIndex < 0 then exit;
177 if ImageType = iltOverlayImages then
178 begin
179 if assigned(RemoteLabeler) then
180 list := RemoteLabeler.FItems.GetOverlayData
181 else
182 list := FItems.GetOverlayData;
183 end
184 else
185 begin
186 if assigned(RemoteLabeler) then
187 list := RemoteLabeler.FItems.GetImageData
188 else
189 list := FItems.GetImageData;
190 end;
191 if ImageIndex < list.Count then
192 ImageText := list[ImageIndex]
193 else
194 ImageText := '';
195end;
196
197procedure TVA508ImageListLabeler.ImageListChange(Sender: TObject);
198var
199 i: integer;
200begin
201 if assigned(FOnChange) then
202 begin
203 FItemChange := FALSE;
204 FImageListChanged := TRUE;
205 try
206 for I := 0 to FItems.Count - 1 do
207 begin
208 FItems.Items[i].Refresh;
209 if FItemChange then
210 break;
211 end;
212 if FItemChange then
213 FOnChange(Self);
214 finally
215 FImageListChanged := FALSE;
216 end;
217 end;
218end;
219
220procedure TVA508ImageListLabeler.ItemChanged;
221begin
222 if FImageListChanged then
223 FItemChange := TRUE
224 else if assigned(FOnChange) then
225 FOnChange(Self);
226end;
227
228procedure TVA508ImageListLabeler.Loaded;
229begin
230 inherited;
231 FStartup := FALSE;
232 Application.ProcessMessages;
233 SaveChanges(FALSE);
234end;
235
236procedure TVA508ImageListLabeler.SaveChanges(Reregister: boolean);
237var
238 i, idx: integer;
239 Item: TVA508ImageListComponent;
240 Comp: TWinControl;
241 NewList: TList;
242 reg: boolean;
243begin
244 if FStartup or (csDesigning in ComponentState) or (not ScreenReaderSystemActive) then exit;
245 if (FComponents.Count = 0) and (FOldComponentList.Count = 0) then exit;
246 NewList := TList.Create;
247 try
248 for i := 0 to FComponents.Count - 1 do
249 begin
250 Item := FComponents.Items[i];
251 if assigned(Item.Component) then
252 begin
253 NewList.Add(Item.Component);
254 idx := FOldComponentList.IndexOf(Item.Component);
255 if idx < 0 then
256 reg := TRUE
257 else
258 begin
259 FOldComponentList.Delete(idx);
260 reg := Reregister;
261 end;
262 if reg then
263 RegisterComponentImageListQueryEvent(Item.Component, Item.ImageListTypes, ImageIndexQuery);
264 end;
265 end;
266 for i := 0 to FOldComponentList.Count-1 do
267 begin
268 Comp := TWinControl(FOldComponentList[i]);
269 UnregisterComponentImageListQueryEvent(Comp, ImageIndexQuery);
270 end;
271 finally
272 FOldComponentList.Free;
273 FOldComponentList := NewList;
274 end;
275end;
276
277procedure TVA508ImageListLabeler.Notification(AComponent: TComponent;
278 Operation: TOperation);
279begin
280 inherited;
281 if (AComponent = FImageList) and (Operation = opRemove) then
282 SetImageList(nil);
283end;
284
285procedure TVA508ImageListLabeler.SetImageList(const Value: TCustomImageList);
286var
287 i,idx: integer;
288 list: string;
289begin
290 if FImageListChanging then exit;
291 if assigned(FRemoteLabeler) then
292 begin
293 FImageList := nil;
294 exit;
295 end;
296 if FImageList <> Value then
297 begin
298 FImageListChanging := TRUE;
299 try
300 if assigned(FImageList) then
301 begin
302 FImageList.UnRegisterChanges(FChangeLink);
303 FImageList.RemoveFreeNotification(Self);
304 end;
305 FImageList := Value;
306 if assigned(FImageList) then
307 begin
308 FImageList.FreeNotification(Self);
309 FImageList.RegisterChanges(FChangeLink);
310 if FImageList.count > 0 then
311 begin
312 list := StringOfChar('x',FImageList.Count);
313 for i := 0 to FItems.Count - 1 do
314 begin
315 idx := FItems[i].ImageIndex + 1;
316 if idx > 0 then
317 list[idx] := ' ';
318 end;
319 for i := 0 to FImageList.Count - 1 do
320 begin
321 if list[i+1] = 'x' then
322 FItems.Add.ImageIndex := i;
323 end;
324 end;
325 end;
326 if assigned(FOnChange) then
327 FOnChange(Self);
328 finally
329 FImageListChanging := FALSE;
330 end;
331 end;
332end;
333
334procedure TVA508ImageListLabeler.SetRemoteLabeler(const Value: TVA508ImageListLabeler);
335begin
336 if (FRemoteLabeler <> Value) then
337 begin
338 if assigned(Value) then
339 begin
340 FItems.Clear;
341 SetImageList(nil);
342 end;
343 FRemoteLabeler := Value;
344 end;
345end;
346
347{ TVA508ImageListItems }
348
349function TVA508ImageListLabels.Add: TVA508ImageListLabel;
350begin
351 Result := TVA508ImageListLabel(inherited Add);
352end;
353
354constructor TVA508ImageListLabels.Create(Owner: TVA508ImageListLabeler);
355begin
356 inherited Create(TVA508ImageListLabel);
357 FImageData := TStringList.Create;
358 FOverlayData := TStringList.Create;
359 FOwner := Owner;
360 FColumns := TStringList.Create;
361 FColumns.Add('Image');
362 FColumns.Add('ImageIndex');
363 FColumns.Add('OverlayIndex');
364 FColumns.Add('Caption');
365end;
366
367destructor TVA508ImageListLabels.Destroy;
368begin
369 Clear;
370 FreeAndNil(FColumns);
371 FreeAndNil(FImageData);
372 FreeAndNil(FOverlayData);
373 inherited;
374end;
375
376function TVA508ImageListLabels.GetAttr(Index: Integer): string;
377begin
378 Result := FColumns[Index];
379end;
380
381function TVA508ImageListLabels.GetAttrCount: Integer;
382begin
383 Result := FColumns.Count;
384end;
385
386function TVA508ImageListLabels.GetImageData: TStrings;
387var
388 i: integer;
389 item: TVA508ImageListLabel;
390begin
391 if (FImageData.Count = 0) and (Count > 0) then
392 begin
393 for i := 0 to Count-1 do
394 begin
395 item := Items[i];
396 while FImageData.Count <= item.ImageIndex do
397 FImageData.Add('');
398 FImageData[item.ImageIndex] := item.Caption;
399 end;
400 end;
401 Result := FImageData;
402end;
403
404function TVA508ImageListLabels.GetItem(Index: Integer): TVA508ImageListLabel;
405begin
406 Result := TVA508ImageListLabel(inherited GetItem(Index));
407end;
408
409function TVA508ImageListLabels.GetItemAttr(Index, ItemIndex: Integer): string;
410begin
411 case Index of
412 0: Result := ' '; // needs something on index 0 or it doesn't display anything on entire line
413 1: if GetItem(ItemIndex).ImageIndex < 0 then
414 Result := ' '
415 else
416 Result := IntToStr(GetItem(ItemIndex).ImageIndex);
417 2: begin
418 if (GetItem(ItemIndex).OverlayIndex < 0) then
419 Result := ' '
420 else
421 Result := IntToStr(GetItem(ItemIndex).OverlayIndex);
422 end;
423 3: Result := GetItem(ItemIndex).Caption;
424 else Result := '';
425 end;
426end;
427
428function TVA508ImageListLabels.GetOverlayData: TStrings;
429var
430 i: integer;
431 item: TVA508ImageListLabel;
432begin
433 if FBuildOverlayData then
434 begin
435 FBuildOverlayData := FALSE;
436 if (Count > 0) then
437 begin
438 for i := 0 to Count-1 do
439 begin
440 item := Items[i];
441 if item.OverlayIndex >= 0 then
442 begin
443 while FOverlayData.Count <= item.OverlayIndex do
444 FOverlayData.Add('');
445 FOverlayData[item.OverlayIndex] := item.Caption;
446 end;
447 end;
448 end;
449 end;
450 Result := FOverlayData;
451end;
452
453function TVA508ImageListLabels.GetOwner: TPersistent;
454begin
455 Result := FOwner;
456end;
457
458procedure TVA508ImageListLabels.Notify(Item: TCollectionItem;
459 Action: TCollectionNotification);
460begin
461 inherited;
462 ResetData;
463end;
464
465procedure TVA508ImageListLabels.ResetData;
466begin
467 FImageData.Clear;
468 FOverlayData.Clear;
469 FBuildOverlayData := TRUE;
470end;
471
472procedure TVA508ImageListLabels.SetItem(Index: Integer; Value: TVA508ImageListLabel);
473begin
474 inherited SetItem(Index, Value);
475end;
476
477procedure TVA508ImageListLabels.Update(Item: TCollectionItem);
478begin
479 inherited;
480 ResetData;
481end;
482
483{ TVA508GraphicLabel }
484
485procedure TVA508ImageListLabel.Assign(Source: TPersistent);
486var
487 item: TVA508ImageListLabel;
488begin
489 if Source is TVA508ImageListLabel then
490 begin
491 item := TVA508ImageListLabel(Source);
492 SetImageIndex(item.ImageIndex);
493 FCaption := item.Caption;
494 end
495 else
496 inherited Assign(Source);
497end;
498
499procedure TVA508ImageListLabel.Changed;
500begin
501 labeler.ItemChanged;
502end;
503
504constructor TVA508ImageListLabel.Create(Collection: TCollection);
505begin
506 inherited Create(Collection);
507 FImageIndex := -1;
508 FOverlayIndex := -1;
509end;
510
511destructor TVA508ImageListLabel.Destroy;
512begin
513 inherited;
514end;
515
516function TVA508ImageListLabel.Labeler: TVA508ImageListLabeler;
517begin
518 Result := TVA508ImageListLabeler(TVA508ImageListLabels(GetOwner).GetOwner);
519end;
520
521procedure TVA508ImageListLabel.Refresh;
522begin
523 SetImageIndex(FImageIndex);
524end;
525
526procedure TVA508ImageListLabel.SetCaption(const Value: string);
527begin
528 if (FCaption <> Value) then
529 begin
530 FCaption := Value;
531 TVA508ImageListLabels(GetOwner).Update(Self);
532 end;
533end;
534
535procedure TVA508ImageListLabel.SetImageIndex(const Value: integer);
536var
537 before: integer;
538begin
539 if csReading in labeler.ComponentState then
540 FImageIndex := Value
541 else
542 begin
543 before := FImageIndex;
544 if not assigned(labeler.ImageList) then
545 FImageIndex := -1
546 else
547 if (Value >= 0) and (Value < labeler.ImageList.Count) then
548 FImageIndex := Value
549 else
550 FImageIndex := -1;
551 if FImageIndex <> before then
552 begin
553 Changed;
554 TVA508ImageListLabels(GetOwner).Update(Self);
555 end;
556 end;
557
558end;
559
560procedure TVA508ImageListLabel.SetOverlayIndex(const Value: integer);
561begin
562 if (FOverlayIndex <> Value) and (Value >= 0) and (Value < 16) then
563 begin
564 FOverlayIndex := Value;
565 end;
566end;
567
568{ TVA508ImageListComponents }
569
570function TVA508ImageListComponents.Add: TVA508ImageListComponent;
571begin
572 Result := TVA508ImageListComponent(inherited Add);
573end;
574
575constructor TVA508ImageListComponents.Create(Owner: TVA508ImageListLabeler);
576begin
577 inherited Create(TVA508ImageListComponent);
578 FOwner := Owner;
579end;
580
581destructor TVA508ImageListComponents.Destroy;
582begin
583 Clear;
584 inherited;
585end;
586
587function TVA508ImageListComponents.GetItem(
588 Index: Integer): TVA508ImageListComponent;
589begin
590 Result := TVA508ImageListComponent(inherited GetItem(Index));
591end;
592
593function TVA508ImageListComponents.GetOwner: TPersistent;
594begin
595 Result := FOwner;
596end;
597
598procedure TVA508ImageListComponents.Notify(Item: TCollectionItem;
599 Action: TCollectionNotification);
600begin
601 inherited;
602 FOwner.SaveChanges(FALSE);
603end;
604
605procedure TVA508ImageListComponents.SetItem(Index: Integer;
606 Value: TVA508ImageListComponent);
607begin
608 inherited SetItem(Index, Value);
609end;
610
611{ TVA508ImageListComponent }
612
613procedure TVA508ImageListComponent.Assign(Source: TPersistent);
614var
615 comp: TVA508ImageListComponent;
616begin
617 if Source is TVA508ImageListComponent then
618 begin
619 comp := TVA508ImageListComponent(Source);
620 comp.Component := FComponent;
621 end
622 else
623 inherited Assign(Source);
624end;
625
626procedure TVA508ImageListComponent.ComponentNotifyEvent(AComponent: TComponent;
627 Operation: TOperation);
628begin
629 if (Operation = opRemove) and assigned(AComponent) and (AComponent = FComponent) then
630 SetComponent(nil);
631end;
632
633destructor TVA508ImageListComponent.Destroy;
634begin
635 SetComponent(nil);
636 if assigned(FComponentNotifier) then
637 FreeAndNil(FComponentNotifier);
638 inherited;
639end;
640
641function TVA508ImageListComponent.GetDisplayName: string;
642begin
643 if assigned(FComponent) and (length(FComponent.Name) > 0) then
644 Result := FComponent.Name + ' (' + FComponent.ClassName + ')'
645 else
646 Result := inherited GetDisplayName;
647end;
648
649type
650 TExposedTreeView = class(TCustomTreeView);
651 TExposedListView = class(TCustomListView);
652
653function TVA508ImageListComponent.ImageListTypes: TVA508ImageListTypes;
654var
655 list: TCustomImageList;
656begin
657 Result := [];
658 list := Labeler.ImageList;
659 if (not assigned(list)) and assigned(Labeler.FRemoteLabeler) then
660 list := Labeler.FRemoteLabeler.ImageList;
661 if (not assigned(list)) then exit;
662 if FComponent is TCustomTreeView then
663 begin
664 with TExposedTreeView(FComponent) do
665 begin
666 if list = Images then
667 Result := Result + [iltImages, iltOverlayImages];
668 if list = StateImages then
669 Include(Result, iltStateImages);
670 end;
671 end
672 else if FComponent is TCustomListView then
673 begin
674 with TExposedListView(FComponent) do
675 begin
676 if list = LargeImages then
677 Result := Result + [iltLargeImages, iltOverlayImages];
678 if list = SmallImages then
679 Result := Result + [iltSmallImages, iltOverlayImages];
680 if list = StateImages then
681 Include(Result, iltStateImages);
682 end;
683 end;
684end;
685
686function TVA508ImageListComponent.Labeler: TVA508ImageListLabeler;
687begin
688 Result := TVA508ImageListLabeler(TVA508ImageListLabels(GetOwner).GetOwner);
689end;
690
691procedure TVA508ImageListComponent.SetComponent(const Value: TWinControl);
692var
693 i: integer;
694 found: boolean;
695begin
696 if FComponent <> Value then
697 begin
698 if assigned(Value) then
699 begin
700 Found := false;
701 for i := low(VA508ImageListLabelerClasses) to high(VA508ImageListLabelerClasses) do
702 begin
703 if Value is VA508ImageListLabelerClasses[i] then
704 begin
705 Found := true;
706 break;
707 end;
708 end;
709 if not found then
710 raise EVA508AccessibilityException.Create('Invalid component class used in ' + TVA508ImageListComponent.ClassName);
711 end;
712 if assigned(FComponentNotifier) and assigned(FComponent) then
713 FComponentNotifier.RemoveFreeNotification(FComponent);
714 if assigned(Value) then
715 begin
716 if not assigned(FComponentNotifier) then
717 FComponentNotifier := TVANotificationEventComponent.NotifyCreate(nil, ComponentNotifyEvent);
718 FComponentNotifier.FreeNotification(Value);
719 end;
720 FComponent := Value;
721 Labeler.SaveChanges(FALSE);
722 end;
723end;
724
725end.
Note: See TracBrowser for help on using the repository browser.