source: cprs/trunk/VA/VA508Accessibility/VA508MSAASupport.pas@ 1696

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

Upgrade to version 27

File size: 20.6 KB
Line 
1unit VA508MSAASupport;
2
3interface
4
5uses
6 Windows, Messages, SysUtils, Classes, Controls, ComObj, ActiveX, oleacc2, MSAAConstants,
7 ImgList, VAClasses, Graphics, ComCtrls, CommCtrl, Contnrs, VA508AccessibilityConst;
8
9type
10 TVA508ImageListType = (iltImages, iltLargeImages, iltOverlayImages, iltSmallImages, iltStateImages);
11 TVA508ImageListTypes = set of TVA508ImageListType;
12
13 TVA508OnImageIndexQueryEvent = procedure(Sender: TObject; ImageIndex: integer;
14 ImageType: TVA508ImageListType; var ImageText: string) of object;
15
16const
17 VA508ImageListLabelerClasses: array[0..1] of TClass = (TCustomTreeView, TCustomListView);
18
19procedure RegisterComponentImageListQueryEvent(Component: TWinControl;
20 ImageListTypes: TVA508ImageListTypes; Event: TVA508OnImageIndexQueryEvent);
21
22procedure UnregisterComponentImageListQueryEvent(Component: TWinControl;
23 Event: TVA508OnImageIndexQueryEvent);
24
25procedure RegisterMSAAComponentQueryProc(Component: TWinControl; Proc: TVA508QueryProc);
26procedure UnregisterMSAAComponentQueryProc(Component: TWinControl; Proc: TVA508QueryProc);
27procedure RegisterMSAAComponentListQueryProc(Component: TWinControl; Proc: TVA508ListQueryProc);
28procedure UnregisterMSAAComponentListQueryProc(Component: TWinControl; Proc: TVA508ListQueryProc);
29
30implementation
31
32var
33 uShutDown: boolean = FALSE;
34 Events: TInterfaceList = nil;
35 AccPropServices: IAccPropServices = nil;
36 NamePropIDs: array[0..0] of TGUID;
37 uNotifier: TVANotificationEventComponent;
38
39type
40 TServerType = (stImageList, stList, stNormal);
41 TServerTypes = set of TServerType;
42
43 TImageEventData = class
44 ImageListTypes: TVA508ImageListTypes;
45 Event: TVA508OnImageIndexQueryEvent;
46 end;
47
48 TListProcData = class
49 Proc: TVA508ListQueryProc;
50 end;
51
52 TProcData = class
53 Proc: TVA508QueryProc;
54 end;
55
56 IMSAAServer = interface
57 function GetComponent: TWinControl;
58 procedure AddImageEvent(ImageListTypes: TVA508ImageListTypes; Event: TVA508OnImageIndexQueryEvent);
59 procedure RemoveImageEvent(ImageListTypes: TVA508ImageListTypes; Event: TVA508OnImageIndexQueryEvent);
60 procedure AddListProc(Proc: TVA508ListQueryProc);
61 procedure RemoveListProc(Proc: TVA508ListQueryProc);
62 procedure AddProc(Proc: TVA508QueryProc);
63 procedure RemoveProc(Proc: TVA508QueryProc);
64 procedure AssignServerType(AServerType: TServerType);
65 function EventCount: integer;
66 end;
67
68 TMSAAServer = class(TInterfacedObject, IAccPropServer, IMSAAServer)
69 private
70 FServerTypes: TServerTypes;
71 FAttached: boolean;
72 FEventData: TObjectList;
73 FComponent: TWinControl;
74 FOldWndProc: TWndMethod;
75 function ImageEventIndex(Event: TVA508OnImageIndexQueryEvent): integer;
76 function ListProcIndex(Proc: TVA508ListQueryProc): integer;
77 function ProcIndex(Proc: TVA508QueryProc): integer;
78 procedure Attach;
79 procedure Detatch;
80 procedure Hook;
81 procedure UnHook;
82 procedure AssignServerType(AServerType: TServerType);
83 procedure UnassignServerType(AServerType: TServerType);
84 protected
85 procedure MSAAWindowProc(var Message: TMessage);
86 public
87 constructor Create(AComponent: TWinControl);
88 destructor Destroy; override;
89 class procedure ValidateServerType(AComponent: TWinControl; AServerType: TServerType);
90 function GetPropValue(const pIDString: PByte; dwIDStringLen: LongWord; idProp: MSAAPROPID;
91 out pvarValue: OleVariant; out pfHasProp: Integer): HResult; stdcall;
92 function GetComponent: TWinControl;
93 procedure AddImageEvent(ImageListTypes: TVA508ImageListTypes; Event: TVA508OnImageIndexQueryEvent);
94 procedure RemoveImageEvent(ImageListTypes: TVA508ImageListTypes; Event: TVA508OnImageIndexQueryEvent);
95 procedure AddListProc(Proc: TVA508ListQueryProc);
96 procedure RemoveListProc(Proc: TVA508ListQueryProc);
97 procedure AddProc(Proc: TVA508QueryProc);
98 procedure RemoveProc(Proc: TVA508QueryProc);
99 function EventCount: integer;
100 end;
101
102 TExposedTreeView = class(TCustomTreeView);
103 TExposedListView = class(TCustomListView);
104
105function FindServer(Component: TWinControl; var index: integer): IMSAAServer; forward;
106
107procedure NotifyEvent(Self: TObject; AComponent: TComponent; Operation: TOperation);
108var
109 server: IMSAAServer;
110 index: integer;
111begin
112 if assigned(Events) and (Operation = opRemove) and (AComponent is TWinControl) then
113 begin
114 server := FindServer(TWinControl(AComponent), index);
115 try
116 if assigned(server) then
117 Events.Delete(index);
118 finally
119 server := nil;
120 end;
121 end;
122end;
123
124var
125 AccServicesCount: integer = 0;
126
127procedure IncAccServices;
128var
129 m: TVANotifyEvent;
130begin
131 if AccServicesCount = 0 then
132 begin
133 AccPropServices := CoCAccPropServices.Create;
134 NamePropIDs[0] := PROPID_ACC_NAME;
135 TMethod(m).Code := @NotifyEvent;
136 TMethod(m).Data := nil;
137 uNotifier := TVANotificationEventComponent.NotifyCreate(nil, m);
138 end;
139 inc(AccServicesCount);
140end;
141
142procedure DecAccServices;
143begin
144 dec(AccServicesCount);
145 if AccServicesCount = 0 then
146 begin
147 FreeAndNil(uNotifier);
148 AccPropServices := nil;
149 end;
150end;
151
152procedure Cleanup;
153begin
154 uShutDown := TRUE;
155 if assigned(Events) then
156 begin
157 Events := nil;
158 DecAccServices;
159 end;
160end;
161
162function FindServer(Component: TWinControl; var index: integer): IMSAAServer;
163var
164 i: integer;
165
166begin
167 if not assigned(Events) then
168 begin
169 Events := TInterfaceList.Create;
170 IncAccServices;
171 end;
172 for I := 0 to Events.Count - 1 do
173 begin
174 Result := IMSAAServer(Events[i]);
175 index := i;
176 if Result.GetComponent = Component then exit;
177 end;
178 Result := nil;
179 index := -1;
180end;
181
182procedure RegisterComponentImageListQueryEvent(Component: TWinControl;
183 ImageListTypes: TVA508ImageListTypes; Event: TVA508OnImageIndexQueryEvent);
184var
185 server: IMSAAServer;
186 index: integer;
187begin
188 if uShutDown then exit;
189 if not assigned(Component) then exit;
190 TMSAAServer.ValidateServerType(Component,stImageList);
191 server := FindServer(Component, index);
192 try
193 if not assigned(server) then
194 begin
195 server := TMSAAServer.Create(Component);
196 Events.Add(server);
197 uNotifier.FreeNotification(Component);
198 end;
199 server.AddImageEvent(ImageListTypes, Event);
200 finally
201 server := nil;
202 end;
203end;
204
205procedure UnregisterComponentImageListQueryEvent(Component: TWinControl;
206 Event: TVA508OnImageIndexQueryEvent);
207var
208 server: IMSAAServer;
209 index: integer;
210begin
211 if uShutDown then exit;
212 if not assigned(Component) then exit;
213 server := FindServer(Component, index);
214 try
215 if assigned(server) then
216 begin
217 uNotifier.RemoveFreeNotification(Component);
218 server.RemoveImageEvent([], Event);
219 if server.EventCount = 0 then
220 Events.Delete(index);
221 end;
222 finally
223 server := nil;
224 end;
225end;
226
227procedure RegisterMSAAComponentQueryProc(Component: TWinControl; Proc: TVA508QueryProc);
228var
229 server: IMSAAServer;
230 index: integer;
231begin
232 if uShutDown then exit;
233 if not assigned(Component) then exit;
234 TMSAAServer.ValidateServerType(Component, stNormal);
235 server := FindServer(Component, index);
236 try
237 if not assigned(server) then
238 begin
239 server := TMSAAServer.Create(Component);
240 Events.Add(server);
241 uNotifier.FreeNotification(Component);
242 end;
243 server.AddProc(Proc);
244 finally
245 server := nil;
246 end;
247end;
248
249procedure UnregisterMSAAComponentQueryProc(Component: TWinControl; Proc: TVA508QueryProc);
250var
251 server: IMSAAServer;
252 index: integer;
253begin
254 if uShutDown then exit;
255 if not assigned(Component) then exit;
256 server := FindServer(Component, index);
257 try
258 if assigned(server) then
259 begin
260 uNotifier.RemoveFreeNotification(Component);
261 server.RemoveProc(Proc);
262 if server.EventCount = 0 then
263 Events.Delete(index);
264 end;
265 finally
266 server := nil;
267 end;
268end;
269
270procedure RegisterMSAAComponentListQueryProc(Component: TWinControl; Proc: TVA508ListQueryProc);
271var
272 server: IMSAAServer;
273 index: integer;
274begin
275 if uShutDown then exit;
276 if not assigned(Component) then exit;
277 TMSAAServer.ValidateServerType(Component, stList);
278 server := FindServer(Component, index);
279 try
280 if not assigned(server) then
281 begin
282 server := TMSAAServer.Create(Component);
283 Events.Add(server);
284 uNotifier.FreeNotification(Component);
285 end;
286 server.AddListProc(Proc);
287 finally
288 server := nil;
289 end;
290end;
291
292procedure UnregisterMSAAComponentListQueryProc(Component: TWinControl; Proc: TVA508ListQueryProc);
293var
294 server: IMSAAServer;
295 index: integer;
296begin
297 if uShutDown then exit;
298 if not assigned(Component) then exit;
299 server := FindServer(Component, index);
300 try
301 if assigned(server) then
302 begin
303 uNotifier.RemoveFreeNotification(Component);
304 server.RemoveListProc(Proc);
305 if server.EventCount = 0 then
306 Events.Delete(index);
307 end;
308 finally
309 server := nil;
310 end;
311end;
312
313{ TMSAAImageListServer }
314
315procedure TMSAAServer.AddImageEvent(ImageListTypes: TVA508ImageListTypes;
316 Event: TVA508OnImageIndexQueryEvent);
317var
318 data: TImageEventData;
319 idx: integer;
320begin
321 idx := ImageEventIndex(Event);
322 if idx < 0 then
323 begin
324 data := TImageEventData.Create;
325 data.Event := Event;
326 FEventData.Add(data);
327 end
328 else
329 data := TImageEventData(FEventData[idx]);
330 data.ImageListTypes := ImageListTypes;
331 AssignServerType(stImageList);
332end;
333
334procedure TMSAAServer.AddListProc(Proc: TVA508ListQueryProc);
335var
336 data: TListProcData;
337 idx: integer;
338begin
339 idx := ListProcIndex(Proc);
340 if idx < 0 then
341 begin
342 data := TListProcData.Create;
343 data.Proc := Proc;
344 FEventData.Add(data);
345 end;
346 AssignServerType(stList);
347end;
348
349procedure TMSAAServer.AddProc(Proc: TVA508QueryProc);
350var
351 data: TProcData;
352 idx: integer;
353begin
354 idx := ProcIndex(Proc);
355 if idx < 0 then
356 begin
357 data := TProcData.Create;
358 data.Proc := Proc;
359 FEventData.Add(data);
360 end;
361 AssignServerType(stNormal);
362end;
363
364procedure TMSAAServer.AssignServerType(AServerType: TServerType);
365begin
366 FServerTypes := FServerTypes + [AServerType];
367end;
368
369procedure TMSAAServer.Attach;
370begin
371 if (not FAttached) and (not uShutDown) and (FComponent.Handle <> 0) then
372 begin
373// if FServerType = stNormal then
374// FAttached := Succeeded(AccPropServices.SetHwndPropServer(FComponent.Handle,
375// OBJID_CLIENT, CHILDID_SELF, @NamePropIDs, 1, Self, ANNO_THIS))
376// else
377 FAttached := Succeeded(AccPropServices.SetHwndPropServer(FComponent.Handle,
378 OBJID_CLIENT, CHILDID_SELF, @NamePropIDs, 1, Self, ANNO_CONTAINER));
379 end;
380end;
381
382constructor TMSAAServer.Create(AComponent: TWinControl);
383begin
384 IncAccServices;
385 FComponent := AComponent;
386 FEventData := TObjectList.Create;
387 if AComponent.Showing then
388 Attach
389 else
390 Hook;
391end;
392
393destructor TMSAAServer.Destroy;
394begin
395 Detatch;
396 FreeAndNil(FEventData);
397 DecAccServices;
398 inherited;
399end;
400
401procedure TMSAAServer.Detatch;
402var
403 Ok2Detatch: boolean;
404begin
405 if FAttached and (not uShutDown) then
406 begin
407 Ok2Detatch := (not (csDestroying in FComponent.ComponentState)) and FComponent.visible;
408 if Ok2Detatch then
409 begin
410 if Succeeded(AccPropServices.ClearHwndProps(FComponent.Handle,
411 OBJID_CLIENT, CHILDID_SELF, @NamePropIDs, 1)) then
412 FAttached := FALSE;
413 end
414 else
415 FAttached := FALSE;
416 end;
417end;
418
419function TMSAAServer.EventCount: integer;
420begin
421 Result := FEventData.Count;
422end;
423
424function TMSAAServer.ImageEventIndex(
425 Event: TVA508OnImageIndexQueryEvent): integer;
426var
427 i: integer;
428 data: TImageEventData;
429begin
430 for i := 0 to FEventData.Count - 1 do
431 begin
432 if FEventData[i] is TImageEventData then
433 begin
434 data := TImageEventData(FEventData[i]);
435 if (TMethod(data.Event).Code = TMethod(Event).Code) and
436 (TMethod(data.Event).Data = TMethod(Event).Data) then
437 begin
438 Result := i;
439 exit;
440 end;
441 end;
442 end;
443 Result := -1;
444end;
445
446function TMSAAServer.ListProcIndex(Proc: TVA508ListQueryProc): integer;
447var
448 i: integer;
449 data: TListProcData;
450begin
451 for i := 0 to FEventData.Count - 1 do
452 begin
453 if FEventData[i] is TListProcData then
454 begin
455 data := TListProcData(FEventData[i]);
456 if @data.Proc = @Proc then
457 begin
458 Result := i;
459 exit;
460 end;
461 end;
462 end;
463 Result := -1;
464end;
465
466function TMSAAServer.GetComponent: TWinControl;
467begin
468 Result := FComponent;
469end;
470
471function TMSAAServer.GetPropValue(const pIDString: PByte;
472 dwIDStringLen: LongWord; idProp: MSAAPROPID; out pvarValue: OleVariant;
473 out pfHasProp: Integer): HResult;
474var
475 phwnd: HWND;
476 pidObject: LongWord;
477 pidChild: LongWord;
478 text, CombinedText: string;
479
480 function Append(data: array of string): string;
481 var
482 i: integer;
483 begin
484 Result := '';
485 for i := low(data) to high(data) do
486 begin
487 if data[i] <> '' then
488 begin
489 if result <> '' then
490 Result := Result + ' ';
491 Result := Result + data[i];
492 end;
493 end;
494 end;
495
496 function GetImageLabelText(ImageListType: TVA508ImageListType; ImageIndex: integer): string;
497 var
498 i: integer;
499 Data: TImageEventData;
500 begin
501 Result := '';
502 for i := 0 to FEventData.Count - 1 do
503 begin
504 if FEventData[i] is TImageEventData then
505 begin
506 data := TImageEventData(FEventData[i]);
507 if ImageListType in data.ImageListTypes then
508 begin
509 data.Event(FComponent, ImageIndex, ImageListType, Result);
510 break;
511 end;
512 end;
513 end;
514 end;
515
516 procedure DoTreeView;
517 var
518 id: HTREEITEM;
519 node: TTreeNode;
520 overlay: string;
521 state: string;
522 tree:TExposedTreeView;
523 begin
524 tree := TExposedTreeView(FComponent);
525 id := HTREEITEM(pidChild);
526 node := tree.Items.GetNode(id);
527 if assigned(node) then
528 begin
529 state := '';
530 overlay := '';
531 // 0 state not valid on tree views
532 if assigned(tree.StateImages) and (node.StateIndex > 0) then
533 state := GetImageLabelText(iltStateImages, node.StateIndex);
534 if node.Selected then
535 text := GetImageLabelText(iltImages, node.SelectedIndex)
536 else
537 text := GetImageLabelText(iltImages, node.ImageIndex);
538 if node.OverlayIndex >= 0 then
539 begin
540 overlay := GetImageLabelText(iltOverlayImages, node.OverlayIndex);
541 end;
542 text := Append([state, text, overlay, node.Text]);
543 end;
544 end;
545
546 procedure DoListView;
547 var
548 view: TExposedListView;
549 ilType: TVA508ImageListType;
550 item: TListItem;
551 state: string;
552 overlay: string;
553 i: integer;
554 coltext: string;
555 begin
556 view := TExposedListView(FComponent);
557 if pidChild > LongWord(view.Items.Count) then exit;
558 state := '';
559 overlay := '';
560 item := view.Items[pidChild-1];
561 if assigned(view.StateImages) then
562 state := GetImageLabelText(iltStateImages, item.StateIndex);
563 if view.ViewStyle = vsIcon then
564 ilType := iltLargeImages
565 else
566 ilType := iltSmallImages;
567 text := GetImageLabelText(ilType, item.ImageIndex);
568 if (item.OverlayIndex >= 0) then
569 overlay := GetImageLabelText(iltOverlayImages, item.OverlayIndex);
570 text := Append([state, text, overlay]);
571
572 if not (stList in FServerTypes) then
573 begin
574 if (view.ViewStyle = vsReport) and (view.Columns.Count > 0) then
575 text := Append([text, view.Columns[0].Caption]);
576 colText := item.Caption;
577 if colText = '' then
578 colText := 'blank';
579 text := Append([text, colText]);
580
581 if view.ViewStyle = vsReport then
582 begin
583 for i := 1 to view.Columns.Count - 1 do
584 begin
585 if view.Columns[i].Width > 0 then
586 begin
587 text := Append([text, view.Columns[i].Caption]);
588 if (i-1) < item.SubItems.Count then
589 colText := item.SubItems[i-1]
590 else
591 colText := '';
592 if colText = '' then
593 colText := 'blank';
594 Text := Append([text, colText + ',']);
595 end;
596 end;
597 end;
598 end;
599 end;
600
601 procedure DoListComponent;
602 var
603 i: integer;
604 data: TListProcData;
605 begin
606 for i := 0 to FEventData.Count - 1 do
607 begin
608 if FEventData[i] is TListProcData then
609 begin
610 data := TListProcData(FEventData[i]);
611 data.Proc(FComponent, pidChild-1, text);
612 end;
613 end;
614 end;
615
616 procedure DoNormalComponent;
617 var
618 i: integer;
619 data: TProcData;
620 begin
621 for i := 0 to FEventData.Count - 1 do
622 begin
623 if FEventData[i] is TProcData then
624 begin
625 data := TProcData(FEventData[i]);
626 data.Proc(FComponent, text);
627 end;
628 end;
629 end;
630
631 procedure HasProperty;
632 begin
633 TVarData(pvarValue).VType := VT_BSTR;
634 pfHasProp := 1;
635 text := '';
636 end;
637
638 procedure NoProperty;
639 begin
640 TVarData(pvarValue).VType := VT_EMPTY;
641 pfHasProp := 0;
642 end;
643
644begin
645 VariantInit(pvarValue);
646 OleCheck(AccPropServices.DecomposeHwndIdentityString(pIDString, dwIDStringLen,
647 phwnd, pidObject, pidChild));
648 if (phwnd = FComponent.Handle) then
649 begin
650 if (pidChild = CHILDID_SELF) then
651 begin
652 if stNormal in FServerTypes then
653 begin
654 HasProperty;
655 DoNormalComponent;
656 pvarValue := text;
657 end
658 else
659 NoProperty;
660 end
661 else
662 begin
663 NoProperty;
664 if (FServerTypes * [stList, stImageList]) <> [] then
665 begin
666 HasProperty;
667 CombinedText := '';
668 if stImageList in FServerTypes then
669 begin
670 if FComponent is TCustomTreeView then DoTreeView else
671 if FComponent is TCustomListView then DoListView;
672 end;
673 CombinedText := text;
674 text := '';
675 if stList in FServerTypes then
676 begin
677 DoListComponent;
678 end;
679 if text <> '' then
680 begin
681 if CombinedText <> '' then
682 CombinedText := CombinedText + ' ';
683 CombinedText := CombinedText + text;
684 end;
685 pvarValue := CombinedText;
686 end;
687 end;
688 end
689 else
690 NoProperty;
691 Result := S_OK;
692end;
693
694procedure TMSAAServer.Hook;
695begin
696 FOldWndProc := FComponent.WindowProc;
697 FComponent.WindowProc := MSAAWindowProc;
698end;
699
700procedure TMSAAServer.RemoveImageEvent(ImageListTypes: TVA508ImageListTypes;
701 Event: TVA508OnImageIndexQueryEvent);
702var
703 idx: integer;
704begin
705 idx := ImageEventIndex(Event);
706 if idx >= 0 then
707 FEventData.Delete(idx);
708 UnassignServerType(stImageList);
709end;
710
711procedure TMSAAServer.RemoveListProc(Proc: TVA508ListQueryProc);
712var
713 idx: integer;
714begin
715 idx := ListProcIndex(Proc);
716 if idx >= 0 then
717 FEventData.Delete(idx);
718 UnassignServerType(stList);
719end;
720
721procedure TMSAAServer.RemoveProc(Proc: TVA508QueryProc);
722var
723 idx: integer;
724begin
725 idx := ProcIndex(Proc);
726 if idx >= 0 then
727 FEventData.Delete(idx);
728 UnassignServerType(stNormal);
729end;
730
731class procedure TMSAAServer.ValidateServerType(AComponent: TWinControl; AServerType: TServerType);
732var
733 i: integer;
734
735begin
736 if AServerType = stImageList then
737 begin
738 for i := low(VA508ImageListLabelerClasses) to high(VA508ImageListLabelerClasses) do
739 begin
740 if AComponent is VA508ImageListLabelerClasses[i] then exit;
741 end;
742 raise TVA508Exception.Create('Unsupported Image List MSAA Label Component');
743 end;
744end;
745
746procedure TMSAAServer.UnassignServerType(AServerType: TServerType);
747begin
748 FServerTypes := FServerTypes - [AServerType];
749end;
750
751procedure TMSAAServer.UnHook;
752begin
753 FComponent.WindowProc := FOldWndProc;
754end;
755
756procedure TMSAAServer.MSAAWindowProc(var Message: TMessage);
757var
758 DoAttach: boolean;
759begin
760 DoAttach := (Message.Msg = CM_SHOWINGCHANGED);
761 FOldWndProc(Message);
762 if DoAttach then
763 begin
764 Unhook;
765 Attach;
766 end;
767end;
768
769function TMSAAServer.ProcIndex(Proc: TVA508QueryProc): integer;
770var
771 i: integer;
772 data: TProcData;
773begin
774 for i := 0 to FEventData.Count - 1 do
775 begin
776 if FEventData[i] is TProcData then
777 begin
778 data := TProcData(FEventData[i]);
779 if @data.Proc = @Proc then
780 begin
781 Result := i;
782 exit;
783 end;
784 end;
785 end;
786 Result := -1;
787end;
788
789initialization
790
791finalization
792 Cleanup;
793
794end.
Note: See TracBrowser for help on using the repository browser.