source: cprs/trunk/VA/VA508Accessibility/VA508AccessibilityManager.pas@ 1085

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

Upgrade to version 27
File size: 109.6 KB
Line 
1unit VA508AccessibilityManager;
2
3interface
4{ TODO -oJeremy Merrill -c508 :Remove Main Form from component list}
5{ TODO -oJeremy Merrill -c508 :
6Figure out a way to handle a component being renamed on a parent form - the child form now
7references the component under a different name }
8uses
9 Windows, Messages, SysUtils, Classes, Controls, StdCtrls, Forms, Contnrs, Dialogs,
10 StrUtils, Buttons, ComCtrls, ExtCtrls, TypInfo, Graphics, VAClasses, VAUtils,
11 VA508AccessibilityConst;
12
13const
14 VA508AccessibilityManagerVersion = '1.10';
15
16type
17 TVA508AccessibilityManager = class;
18 TVA508AccessibilityCollection = class;
19 TVA508ComponentManager = class;
20
21 TVA508AccessibilityStatus = (stsOK, stsNoTabStop, stsDefault, stsNoData);
22
23 TVA508AccessibilityItem = class(TCollectionItem)
24 private
25 FComponent: TWinControl;
26 FComponentManager: TVA508ComponentManager;
27 FLabel: TLabel;
28 FProperty: string;
29 FText: string;
30 FDefault: boolean;
31 FStatus: TVA508AccessibilityStatus;
32 procedure SetComponent(const Component: TWinControl);
33 procedure InitComponent(const Component: TWinControl; FromManager: boolean);
34 procedure SetLabel(const Value: TLabel);
35 procedure SetProperty(const Value: string);
36 procedure SetText(const Value: string);
37 function Parent: TVA508AccessibilityCollection;
38 procedure SetDefault(const Value: boolean);
39 protected
40 function GetDisplayName: string; override;
41 public
42 constructor Create(Collection: TCollection); override;
43 destructor Destroy; override;
44 procedure Assign(Source: TPersistent); override;
45 procedure UpdateStatus;
46 function Manager: TVA508AccessibilityManager;
47 property Status: TVA508AccessibilityStatus read FStatus write FStatus;
48 property ComponentManager: TVA508ComponentManager read FComponentManager write FComponentManager;
49 published
50 property AccessLabel: TLabel read FLabel write SetLabel;
51 property AccessProperty: string read FProperty write SetProperty;
52 property AccessText: string read FText write SetText;
53 property Component: TWinControl read FComponent write SetComponent;
54 property UseDefault: boolean read FDefault write SetDefault;
55 property DisplayName: string read GetDisplayName;
56 end;
57
58 TVA508AccessibilityCollection = class(TCollection)
59 private
60 FRegistry: TStringList;
61 FManager: TVA508AccessibilityManager;
62 FNotifier: TVANotificationEventComponent;
63 procedure ComponentNotifyEvent(AComponent: TComponent; Operation: TOperation);
64 protected
65 function IsComponentRegistered(Component: TWinControl): boolean;
66 procedure RegisterComponent(Component: TWinControl; Item: TVA508AccessibilityItem);
67 procedure UnregisterComponent(Component: TWinControl);
68 function GetItem(Index: Integer): TVA508AccessibilityItem;
69 procedure SetItem(Index: Integer; Value: TVA508AccessibilityItem);
70 function GetOwner: TPersistent; override;
71// procedure Update(Item: TCollectionItem); override;
72 public
73 constructor Create(Manager: TVA508AccessibilityManager);
74 destructor Destroy; override;
75 procedure EnsureItemExists(Component: TWinControl);
76 function FindItem(Component: TWinControl; CreateIfNotFound: boolean = true): TVA508AccessibilityItem;
77 function Add: TVA508AccessibilityItem;
78 property Items[Index: Integer]: TVA508AccessibilityItem read GetItem write SetItem; default;
79 end;
80
81 TVA508AccessibilityManager = class(TComponent)
82 private
83 FDFMData: TObjectList;
84 FData: TVA508AccessibilityCollection;
85 function GetAccessLabel(Component: TWinControl): TLabel;
86 function GetAccessProperty(Component: TWinControl): String;
87 function GetAccessText(Component: TWinControl): String;
88 procedure SetAccessLabel(Component: TWinControl; const Value: TLabel);
89 procedure SetAccessProperty(Component: TWinControl; const Value: String);
90 procedure SetAccessText(Component: TWinControl; const Value: String);
91 function GetRootComponent(Component: TComponent; var PropertyName: String): TComponent;
92 function GetDefaultStringProperty(AComponent: TWinControl): String;
93 procedure Initialize;
94 function GetData: TVA508AccessibilityCollection;
95 function OwnerCheck(Component: TComponent): boolean;
96 function FindComponentOnForm(ComponentName: String): TComponent;
97 procedure ReadData(Reader: TReader);
98 procedure WriteData(Writer: TWriter);
99 function GetUseDefault(Component: TWinControl): boolean;
100 procedure SetUseDefault(Component: TWinControl; const Value: boolean);
101 function GetComponentManager(
102 Component: TWinControl): TVA508ComponentManager;
103 procedure SetComponentManager(Component: TWinControl;
104 const Value: TVA508ComponentManager);
105 protected
106 procedure DefineProperties(Filer: TFiler); override;
107 procedure Loaded; override;
108 function GetPropertList(Component: TWinControl): TStrings;
109 function IsPropertyNameValid(Component: TWinControl; PropertyName: String): boolean;
110 function ScreenReaderInquiry(Component: TWinControl): string;
111 procedure Notification(AComponent: TComponent; Operation: TOperation); override;
112 function GetComponentName(AComponent: TComponent): String;
113 procedure GetLabelStrings(list: TStringList);
114 procedure GetProperties(Component: TWinControl; list: TStrings);
115 public
116 constructor Create(AOwner: TComponent); override;
117 destructor Destroy; override;
118 procedure RefreshComponents;
119 property AccessText[Component: TWinControl]: string
120 read GetAccessText
121 write SetAccessText;
122 property AccessLabel[Component: TWinControl]: TLabel
123 read GetAccessLabel
124 write SetAccessLabel;
125 property AccessProperty[Component: TWinControl]: string
126 read GetAccessProperty
127 write SetAccessProperty;
128 property ComponentManager[Component: TWinControl]: TVA508ComponentManager
129 read GetComponentManager
130 write SetComponentManager;
131 property UseDefault[Component: TWinControl]: boolean
132 read GetUseDefault
133 write SetUseDefault;
134 published
135 property AccessData: TVA508AccessibilityCollection read GetData write FData stored FALSE;
136 end;
137
138 IVA508CustomDefaultCaption = interface(IInterface)
139 ['{ED1E68FD-5432-4C9D-A250-2069F3A2CABE}']
140 function GetDefaultCaption: string;
141 end;
142
143 TVA508ScreenReaderEvent = procedure(Sender: TObject; var Text: String) of object;
144 TVA508ScreenReaderItemEvent = procedure(Sender: TObject; var Item: TObject) of object;
145
146 TVA508ComponentAccessibility = class(TComponent)
147 private
148 FOnComponentNameQuery: TVA508ScreenReaderEvent;
149 FOnCaptionQuery: TVA508ScreenReaderEvent;
150 FOnValueQuery: TVA508ScreenReaderEvent;
151 FOnStateQuery: TVA508ScreenReaderEvent;
152 FOnInstructionsQuery: TVA508ScreenReaderEvent;
153 FOnItemInstructionsQuery: TVA508ScreenReaderEvent;
154 FOnItemQuery: TVA508ScreenReaderItemEvent;
155 FComponentName: string;
156 FCaption: string;
157 FInstructions: string;
158 FItemInstructions: string;
159 FComponent: TWinControl;
160 procedure SetComponent(const Value: TWinControl);
161 protected
162 { Protected declarations }
163 public
164 { Public declarations }
165 published
166 { Published declarations }
167 constructor Create(AOwner: TComponent); override;
168 property Component: TWinControl read FComponent write SetComponent;
169 property OnComponentNameQuery: TVA508ScreenReaderEvent read FOnComponentNameQuery write FOnComponentNameQuery;
170 property OnCaptionQuery: TVA508ScreenReaderEvent read FOnCaptionQuery write FOnCaptionQuery;
171 property OnValueQuery: TVA508ScreenReaderEvent read FOnValueQuery write FOnValueQuery;
172 property OnStateQuery: TVA508ScreenReaderEvent read FOnStateQuery write FOnStateQuery;
173 property OnInstructionsQuery: TVA508ScreenReaderEvent read FOnInstructionsQuery write FOnInstructionsQuery;
174 property OnItemInstructionsQuery: TVA508ScreenReaderEvent read FOnItemInstructionsQuery write FOnItemInstructionsQuery;
175 property OnItemQuery: TVA508ScreenReaderItemEvent read FOnItemQuery write FOnItemQuery;
176 property ComponentName: string read FComponentName write FComponentName;
177 property Caption: string read FCaption write FCaption;
178 property Instructions: string read FInstructions write FInstructions;
179 property ItemInstructions: string read FItemInstructions write FItemInstructions;
180 end;
181
182// automatically freed when component is destroyed
183 TManagedType = (mtNone, mtCaption, mtComponentName, mtInstructions, mtValue, mtData,
184 mtState, mtStateChange, // NOTE - should ALWAYS use mtStateChange when mtState is used!!!
185 mtItemChange, mtItemInstructions, mtComponentRedirect);
186 TManagedTypes = set of TManagedType;
187
188 TVA508ComponentManager = class(TObject)
189 private
190 FManagedTypes: TManagedTypes;
191 protected
192 constructor Create(ManagedTypes: TManagedTypes); overload;
193 public
194 constructor Create; overload; virtual; abstract;
195 function GetCaption(Component: TWinControl): string; virtual;
196 function GetComponentName(Component: TWinControl): string; virtual;
197 function GetInstructions(Component: TWinControl): string; virtual;
198 function GetItemInstructions(Component: TWinControl): string; virtual;
199 function GetValue(Component: TWinControl): string; overload; virtual;
200 function GetData(Component: TWinControl; Value: string): string; overload; virtual;
201 function GetState(Component: TWinControl): string; virtual;
202 function GetItem(Component: TWinControl): TObject; virtual;
203 function ManageCaption(Component: TWinControl): boolean; virtual;
204 function ManageComponentName(Component: TWinControl): boolean; virtual;
205 function ManageInstructions(Component: TWinControl): boolean; virtual;
206 function ManageItemInstructions(Component: TWinControl): boolean; virtual;
207 function ManageValue(Component: TWinControl): boolean; virtual;
208 function ManageData(Component: TWinControl): boolean; virtual;
209 function ManageState(Component: TWinControl): boolean; virtual;
210 function MonitorForStateChange(Component: TWinControl): boolean; virtual;
211 function MonitorForItemChange(Component: TWinControl): boolean; virtual;
212 function RedirectsComponent(Component: TWinControl): boolean; virtual;
213 function Redirect(Component: TWinControl; var ManagedType: TManagedType): TWinControl; virtual;
214 end;
215
216 TVA508StaticText = class;
217
218 TVA508ChainedLabel = class(TLabel)
219 private
220 FStaticLabelParent: TVA508StaticText;
221 FPreviousLabel: TControl;
222 FNextLabel: TVA508ChainedLabel;
223 procedure SetNextLabel(const Value: TVA508ChainedLabel);
224 protected
225 procedure Notification(AComponent: TComponent; Operation: TOperation); override;
226 procedure Paint; override;
227 public
228 property NextLabel: TVA508ChainedLabel read FNextLabel write SetNextLabel;
229 end;
230
231 TVA508StaticText = class(TPanel)
232 private
233 FLabel: TLabel;
234 FOnEnter: TNotifyEvent;
235 FOnExit: TNotifyEvent;
236 FNextLabel: TVA508ChainedLabel;
237 FDeletingChain: boolean;
238 FInitTabStop: boolean;
239 procedure DeleteChain(FromLabel, ToLabel: TVA508ChainedLabel);
240 procedure SetNextLabel(const Value: TVA508ChainedLabel);
241 function GetLabelCaption: string;
242 procedure SetLabelCaption(const Value: string);
243 function GetRootName: string;
244 procedure SetRootName(const Value: string);
245 function GetShowAccelChar: boolean;
246 procedure SetShowAccelChar(const Value: boolean);
247 procedure UpdateSize;
248 procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
249 procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
250 function GetAlignment: TAlignment;
251 procedure SetAlignment(const Value: TAlignment);
252 protected
253 procedure Notification(AComponent: TComponent; Operation: TOperation); override;
254 procedure DoEnter; override;
255 procedure DoExit; override;
256 procedure Paint; override;
257 procedure SetParent(AParent: TWinControl); override;
258 property StaticLabel: TLabel read FLabel;
259 public
260 constructor Create(AOwner: TComponent); override;
261 destructor Destroy; override;
262 procedure InvalidateAll;
263 property NextLabel: TVA508ChainedLabel read FNextLabel write SetNextLabel;
264 published
265 property TabStop default false;
266 property OnEnter: TNotifyEvent read FOnEnter write FOnEnter;
267 property OnExit: TNotifyEvent read FOnExit write FOnExit;
268 property Caption: string read GetLabelCaption write SetLabelCaption;
269 property Name: string read GetRootName write SetRootName;
270 property ShowAccelChar: boolean read GetShowAccelChar write SetShowAccelChar;
271 property Alignment: TAlignment read GetAlignment write SetAlignment;
272 end;
273
274 TVA508SilentComponent = class(TVA508ComponentManager)
275 public
276 function GetComponentName(Component: TWinControl): string; override;
277 function GetInstructions(Component: TWinControl): string; override;
278 function GetValue(Component: TWinControl): string; override;
279 function GetState(Component: TWinControl): string; override;
280 end;
281
282 TVA508AlternateHandleFunc = function(Component: TWinControl): HWnd;
283
284 TVA508ManagedComponentClass = class(TVA508ComponentManager)
285 private
286 FClassType: TWinControlClass;
287 FManageDescendentClasses: boolean;
288 protected
289 constructor Create(AClassType: TWinControlClass; ManageTypes: TManagedTypes;
290 AManageDescendentClasses: boolean = FALSE); overload;
291 property ManageDescendentClasses: boolean read FManageDescendentClasses write FManageDescendentClasses;
292 public
293 property ComponentClassType: TWinControlClass read FClassType;
294 end;
295
296 TVA508ComplexComponentManager = class(TObject)
297 private
298 FComponentList: TObjectList;
299 FSubComponentXRef: TObjectList;
300 FComponentClass: TWinControlClass;
301 FComponentNotifier: TVANotificationEventComponent;
302 FSubComponentNotifier: TVANotificationEventComponent;
303 procedure ComponentNotifyEvent(AComponent: TComponent; Operation: TOperation);
304 procedure SubComponentNotifyEvent(AComponent: TComponent; Operation: TOperation);
305 function IndexOfComponentItem(Component: TWinControl): integer;
306 function IndexOfSubComponentXRef(Component: TWinControl): integer;
307 function GetSubComponentList(Component: TWinControl): TList;
308 protected
309 procedure ClearSubControls(Component: TWinControl);
310 procedure AddSubControl(ParentComponent, SubControl: TWinControl;
311 AccessibilityManager: TVA508AccessibilityManager);
312 procedure RemoveSubControl(ParentComponent, SubControl: TWinControl);
313 public
314 constructor Create(AComponentClass: TWinControlClass); overload;
315 destructor Destroy; override;
316 procedure Refresh(Component: TWinControl;
317 AccessibilityManager: TVA508AccessibilityManager); virtual; abstract;
318 function SubControlCount(Component: TWinControl): integer;
319 function GetSubControl(Component: TWinControl; Index: integer): TWinControl;
320 property ComponentClass: TWinControlClass read FComponentClass;
321 end;
322
323
324procedure RegisterAlternateHandleComponent(ComponentClass: TWinControlClass;
325 AlternateHandleFunc: TVA508AlternateHandleFunc);
326procedure RegisterComplexComponentManager(Manager: TVA508ComplexComponentManager);
327procedure RegisterManagedComponentClass(Manager: TVA508ManagedComponentClass);
328procedure RegisterMSAAQueryClassProc(MSAAClass: TWinControlClass; Proc: TVA508QueryProc);
329procedure RegisterMSAAQueryListClassProc(MSAAClass: TWinControlClass; Proc: TVA508ListQueryProc);
330
331const
332 ComponentManagerSilentText = ' '; // '' does not silence the screen reader
333
334 AccessibilityLabelPropertyName = 'AccessLabel';
335 AccessibilityPropertyPropertyName = 'AccessProperty';
336 AccessibilityTextPropertyName = 'AccessText';
337 AccessibilityUseDefaultPropertyName = 'UseDefault';
338// AccessibilityEventPropertyName = 'OnAccessRequest'; // AccessEvent
339
340 AccessDataStatusText = 'Status';
341 AccessDataLabelText = 'Label';
342 AccessDataPropertyText = 'Property';
343 AccessDataTextText = 'Text';
344// AccessDataEventText = 'Event';
345 AccessDataComponentText = 'Component';
346
347 VA508DataPropertyName = 'AccessData';
348 VA508DFMDataPropertyName = 'Data';
349
350 EQU = ' = ';
351 EQU_LEN = length(EQU);
352
353type
354 TDefaultStringPropertyValuePair = record
355 ClassType: TWinControlClass;
356 PublishedPropertyName: String;
357 end;
358
359const
360 CaptionedControlClassCount = 6;
361 CaptionProperty = 'Caption';
362 ControlsWithDefaultPropertySettings: array[1..CaptionedControlClassCount] of TDefaultStringPropertyValuePair =
363
364 ((ClassType: TCustomForm; PublishedPropertyName: CaptionProperty),
365 // includes TButton, TBitBtn, TCheckBox, TRadioButton, TDBCheckBox, and TGroupButton
366 (ClassType: TButtonControl; PublishedPropertyName: CaptionProperty),
367 // includes TPanel, TFlowPanel and TGridPanel, but not TDBNAvigator or TDecisionPivot
368 // because they do not have a published Caption property
369 (ClassType: TCustomPanel; PublishedPropertyName: CaptionProperty),
370 // Includes TGroupBox, TRadioGroup and TDBRadioGroupBox
371 (ClassType: TCustomGroupBox; PublishedPropertyName: CaptionProperty),
372 // TStaticText only
373 (ClassType: TCustomStaticText; PublishedPropertyName: CaptionProperty),
374 // TLabeledEdit only
375 (ClassType: TCustomLabeledEdit; PublishedPropertyName: 'EditLabel.' + CaptionProperty));
376
377implementation
378
379// VA508DelphiCompatibility added to ensure initialization section runs
380uses ComObj, VA508Classes, VA508AccessibilityRouter, VA508DelphiCompatibility,
381 VA508ScreenReaderDLLLinker, Types, VA508MSAASupport;
382
383type
384 TVA508RegistrationScreenReader = class(TVA508ScreenReader);
385
386 TComponentHelper = class(TObject)
387 private
388 FRedirectedComponent: TWinControl;
389 FRedirectedHelper: TComponentHelper;
390 FRedirectedHelperType: TManagedType;
391 FHandleKey: string;
392 FComponent: TWinControl;
393 FManager: TVA508AccessibilityManager;
394 FManagedClassData: TVA508ManagedComponentClass;
395 FFieldObject: TVA508ComponentAccessibility;
396 FComponentManager: TVA508ComponentManager;
397 FComplexManager: TVA508ComplexComponentManager;
398 procedure ClearRedirect;
399 function Redirect(RedirectType: TManagedType): boolean;
400 published
401 public
402 constructor Create;
403 destructor Destroy; override;
404 procedure InitializeComponentManager;
405 function GetCaption(var DataResult: LongInt): string;
406 function GetComponentName(var DataResult: LongInt): string;
407 function GetInstructions(var DataResult: LongInt): string;
408 function GetItemInstructions(var DataResult: LongInt): string;
409 function GetValue(var DataResult: LongInt): string;
410 function GetData(var DataResult: LongInt; Value: string): string;
411 function GetState(var DataResult: LongInt): string;
412 function GetItem: TObject;
413 function ManageComponentName: boolean;
414 function ManageInstructions: boolean;
415 function ManageItemInstructions: boolean;
416 function ManageValue: boolean;
417 function ManageData: boolean;
418 function MonitorForStateChange: boolean;
419 function MonitorForItemChange: boolean;
420 function ManageCaption: boolean;
421 function StandardComponent: boolean;
422 property ComponentManager: TVA508ComponentManager read FComponentManager;
423 property HandleKey: string read FHandleKey write FHandleKey;
424 property Component: TWinControl read FComponent write FComponent;
425 property Manager: TVA508AccessibilityManager read FManager write FManager;
426 property ManagedClassData: TVA508ManagedComponentClass read FManagedClassData write FManagedClassData;
427 property FieldObject: TVA508ComponentAccessibility read FFieldObject write FFieldObject;
428 property ComplexManager: TVA508ComplexComponentManager read FComplexManager write FComplexManager;
429 end;
430
431 TComponentData = record
432 Handle: HWND;
433 CaptionQueried: boolean;
434 ValueQueried: boolean;
435 StateQueried: boolean;
436 ItemInstrQueried: boolean;
437 Caption: string;
438 Item: TObject;
439 State: string;
440 ItemInstructions: string;
441 end;
442
443const
444 IIDelim = '^';
445
446 NewComponentData: TComponentData =
447 (Handle: 0;
448 CaptionQueried: FALSE;
449 ValueQueried: FALSE;
450 StateQueried: FALSE;
451 ItemInstrQueried: FALSE;
452 Caption: '';
453 Item: nil;
454 State: '';
455 ItemInstructions: IIDelim);
456type
457 TScreenReaderEventType = (sreCaption, sreValue, sreState, sreInstructions, sreItemInstructions);
458
459 TVAGlobalComponentRegistry = class(TObject)
460 private
461 class var
462 FActive: boolean;
463 FGetMsgHookHandle: HHOOK;
464 private
465 FCurrentHelper: TComponentHelper;
466 FDestroying: boolean;
467 FComponentRegistry: TStringList;
468 FHandlesXREF: TStringList;
469 FHandlesPending: TStringList;
470 FPendingRecheckTimer: TTimer;
471 FCheckingPendingList: boolean;
472 FUnregisteringComponent: boolean;
473 FComponentData: TComponentData;
474 FPendingFieldObjects: TStringList;
475 function GetComponentHelper(WindowHandle: HWND): TComponentHelper;
476 procedure CheckForChangeEvent;
477 function GetComponentHandle(Component: TWinControl): Hwnd;
478 function HasHandle(Component: TWinControl; var HandleKey: String): boolean;
479 function GetCompKey(Component: TWinControl): String;
480 procedure UpdateHandles(WindowHandle: HWnd; var HandlesModified: boolean);
481 protected
482 procedure TimerEvent(Sender: TObject);
483 procedure ComponentDataNeededEvent(const WindowHandle: HWND; var DataStatus: LongInt;
484 var Caption: PChar; var Value: PChar; var Data: PChar; var ControlType: PChar;
485 var State: PChar; var Instructions: PChar; var ItemInstructions: PChar);
486 procedure RegisterMSAA(Component: TWinControl);
487 procedure UnregisterMSAA(Component: TWinControl);
488 public
489 constructor Create;
490 destructor Destroy; override;
491 function GetFieldObject(Component: TWinControl): TVA508ComponentAccessibility;
492 procedure RegisterFieldObject(Component: TWinControl; FieldObject: TVA508ComponentAccessibility;
493 Adding: boolean);
494 procedure RegisterComponent(component: TWinControl; Manager: TVA508AccessibilityManager);
495 procedure UnregisterComponent(component: TWinControl);
496 end;
497
498 TDFMData = class(TObject)
499 private
500 ComponentName: string;
501 LabelName: string;
502 PropertyName: string;
503 Text: string;
504 Status: TVA508AccessibilityStatus;
505// Event: TVA508ComponentScreenReaderEvent;
506 end;
507
508 TMSAAData = class(TObject)
509 private
510 MSAAClass: TWinControlClass;
511 Proc: TVA508QueryProc;
512 ListProc: TVA508ListQueryProc;
513 end;
514
515{ TVA508AccessibilityItem }
516
517const
518 INVALID_COMPONENT_ERROR = 'Internal Error - Invalid Component';
519 NAME_DELIM = '.';
520
521var
522 MasterPropertyList: TStringList = nil;
523 GlobalRegistry: TVAGlobalComponentRegistry = nil;
524 AltHandleClasses: TObjectList = nil;
525 ManagedClasses: TObjectList = nil;
526 ComplexClasses: TObjectList = nil;
527 MSAAQueryClasses: TObjectList = nil;
528
529procedure CreateGlobalRegistry;
530begin
531 if ScreenReaderSystemActive and (not assigned(GlobalRegistry)) then
532 GlobalRegistry := TVAGlobalComponentRegistry.Create;
533end;
534
535procedure CreateGlobalVars;
536begin
537 if not assigned(MasterPropertyList) then
538 MasterPropertyList := TStringList.create;
539 CreateGlobalRegistry;
540end;
541
542procedure FreeGlobalVars;
543begin
544 if assigned(MasterPropertyList) then
545 FreeAndNilTStringsAndObjects(MasterPropertyList);
546 if assigned(GlobalRegistry) then
547 FreeAndNil(GlobalRegistry);
548 if assigned(AltHandleClasses) then
549 FreeAndNil(AltHandleClasses);
550 if assigned(ManagedClasses) then
551 FreeAndNil(ManagedClasses);
552 if assigned(ComplexClasses) then
553 FreeAndNil(ComplexClasses);
554 if assigned(MSAAQueryClasses) then
555 FreeAndNil(MSAAQueryClasses);
556end;
557
558procedure TVA508AccessibilityItem.Assign(Source: TPersistent);
559var
560 item: TVA508AccessibilityItem;
561begin
562 if Source is TVA508AccessibilityItem then
563 begin
564 item := TVA508AccessibilityItem(Source);
565 FComponent := item.FComponent;
566 FComponentManager := item.ComponentManager;
567 FLabel := item.FLabel;
568 FProperty := item.FProperty;
569 FText := item.FText;
570 FDefault := item.FDefault;
571 FStatus := item.FStatus;
572 end
573 else inherited Assign(Source);
574end;
575
576constructor TVA508AccessibilityItem.Create(Collection: TCollection);
577begin
578 inherited Create(Collection);
579end;
580
581destructor TVA508AccessibilityItem.Destroy;
582begin
583 Parent.UnregisterComponent(FComponent);
584 if assigned(FComponentManager) then
585 FreeAndNil(FComponentManager);
586 inherited;
587end;
588
589function TVA508AccessibilityItem.GetDisplayName: string;
590begin
591 if assigned(FComponent) then
592 begin
593 Result := Manager.GetComponentName(FComponent) +
594 ' (' + FComponent.ClassName + ')'
595 end
596 else
597 Result := TVA508AccessibilityItem.ClassName;
598end;
599
600procedure TVA508AccessibilityItem.InitComponent(const Component: TWinControl; FromManager: boolean);
601begin
602 FComponent := Component;
603 if FromManager and (not (csReading in Manager.ComponentState)) then
604 FDefault := TRUE;
605end;
606
607function TVA508AccessibilityItem.Manager: TVA508AccessibilityManager;
608begin
609 Result := TVA508AccessibilityCollection(Collection).FManager;
610end;
611
612function TVA508AccessibilityItem.Parent: TVA508AccessibilityCollection;
613begin
614 Result := TVA508AccessibilityCollection(Collection);
615end;
616
617procedure TVA508AccessibilityItem.SetComponent(const Component: TWinControl);
618begin
619 if (FComponent <> Component) and
620 (([csDesigning, csFixups, csLoading, csReading, csUpdating] * Manager.ComponentState) <> []) and
621 (not Parent.IsComponentRegistered(Component)) then
622 begin
623 Parent.UnregisterComponent(FComponent);
624 InitComponent(Component, FALSE);
625 Parent.RegisterComponent(Component, Self);
626 end;
627end;
628
629procedure TVA508AccessibilityItem.SetDefault(const Value: boolean);
630begin
631 if FDefault <> Value then
632 begin
633 FDefault := Value;
634 if FDefault then
635 begin
636 FLabel := nil;
637 FText := '';
638 FProperty := '';
639 end
640 else if (FProperty = '') and (not (csReading in Manager.ComponentState)) then
641 FProperty := Manager.GetDefaultStringProperty(FComponent);
642 end;
643end;
644
645procedure TVA508AccessibilityItem.SetLabel(const Value: TLabel);
646begin
647 if FLabel <> Value then
648 begin
649 FLabel := Value;
650 if assigned(FLabel) then
651 begin
652 FProperty := '';
653 FText := '';
654 FDefault := FALSE;
655 end;
656 end;
657end;
658
659procedure TVA508AccessibilityItem.SetProperty(const Value: string);
660begin
661 if (FProperty <> Value) and
662 ((Value = '') or (csreading in Manager.ComponentState) or
663 Manager.IsPropertyNameValid(Component, Value)) then
664 begin
665 FProperty := Value;
666 if (FProperty <> '') then
667 begin
668 FLabel := nil;
669 FText := '';
670 FDefault := FALSE;
671 end;
672 end;
673end;
674
675procedure TVA508AccessibilityItem.SetText(const Value: string);
676begin
677 if FText <> Value then
678 begin
679 FText := Value;
680 if FText <> '' then
681 begin
682 FLabel := nil;
683 FProperty := '';
684 FDefault := FALSE;
685 end;
686 end;
687end;
688
689procedure TVA508AccessibilityItem.UpdateStatus;
690begin
691 FStatus := stsNoData;
692 if assigned(FComponent) then
693 begin
694 if FDefault then
695 FStatus := stsDefault
696 else
697{ TODO : FIX THIS!!!!!!!!!!!!!!!! }
698 if assigned(FLabel) or (AccessProperty <> '') or (FText <> '') then //or assigned(FEvent) then
699 FStatus := stsOK
700 else
701 if FComponent.TabStop = FALSE then
702 FStatus := stsNoTabStop;
703 end;
704end;
705
706{ TVA508AccessibilityCollection }
707
708function TVA508AccessibilityCollection.Add: TVA508AccessibilityItem;
709begin
710 Result := TVA508AccessibilityItem(inherited Add);
711end;
712
713procedure TVA508AccessibilityCollection.ComponentNotifyEvent(
714 AComponent: TComponent; Operation: TOperation);
715var
716 item: TVA508AccessibilityItem;
717begin
718 if (Operation = opRemove) and (AComponent is TWinControl) then
719 begin
720 if ScreenReaderSystemActive then
721 GlobalRegistry.UnregisterComponent(TWinControl(AComponent));
722 item := FindItem(TWinControl(AComponent), FALSE);
723 if assigned(item) then
724 item.Free;
725 end;
726end;
727
728constructor TVA508AccessibilityCollection.Create(
729 Manager: TVA508AccessibilityManager);
730begin
731 inherited Create(TVA508AccessibilityItem);
732 FManager := Manager;
733 FRegistry := TStringList.Create;
734 FRegistry.Sorted := TRUE;
735 FRegistry.Duplicates := dupAccept; // speeds things up
736 FNotifier := TVANotificationEventComponent.NotifyCreate(nil, ComponentNotifyEvent);
737end;
738
739destructor TVA508AccessibilityCollection.Destroy;
740begin
741 FNotifier.OnNotifyEvent := nil;
742 FNotifier.Free;
743 FRegistry.Free;
744 inherited;
745end;
746
747procedure TVA508AccessibilityCollection.EnsureItemExists(
748 Component: TWinControl);
749begin
750 FindItem(Component);
751end;
752
753function TVA508AccessibilityCollection.FindItem(
754 Component: TWinControl; CreateIfNotFound: boolean = true): TVA508AccessibilityItem;
755var
756 key: string;
757 idx: integer;
758begin
759 Result := nil;
760 if assigned(Component) then
761 begin
762 key := FastIntToHex(Integer(Component));
763 idx := FRegistry.IndexOf(key);
764 if idx < 0 then
765 begin
766 if CreateIfNotFound then
767 begin
768 Result := Add;
769 Result.InitComponent(Component, TRUE);
770 RegisterComponent(Component, Result);
771 end;
772 end
773 else
774 Result := TVA508AccessibilityItem(FRegistry.Objects[idx]);
775 end;
776end;
777
778function TVA508AccessibilityCollection.GetItem(
779 Index: Integer): TVA508AccessibilityItem;
780begin
781 Result := TVA508AccessibilityItem(inherited GetItem(Index));
782end;
783
784function TVA508AccessibilityCollection.GetOwner: TPersistent;
785begin
786 Result := FManager;
787end;
788
789function TVA508AccessibilityCollection.IsComponentRegistered(
790 Component: TWinControl): boolean;
791begin
792 if assigned(Component) then
793 Result := FRegistry.IndexOf(FastIntToHex(Integer(Component))) >= 0
794 else
795 Result := TRUE;
796end;
797
798procedure TVA508AccessibilityCollection.UnregisterComponent(
799 Component: TWinControl);
800var
801 key: string;
802 idx: integer;
803begin
804 if ScreenReaderSystemActive then
805 GlobalRegistry.UnregisterComponent(Component);
806 if not assigned(Component) then exit;
807 key := FastIntToHex(Integer(Component));
808 idx := FRegistry.IndexOf(key);
809 if idx >= 0 then
810 begin
811 FRegistry.Delete(idx);
812 Component.RemoveFreeNotification(FNotifier);
813 end;
814end;
815
816procedure TVA508AccessibilityCollection.SetItem(Index: Integer;
817 Value: TVA508AccessibilityItem);
818begin
819 inherited SetItem(Index, Value);
820end;
821{
822procedure TVA508AccessibilityCollection.Update(Item: TCollectionItem);
823begin
824 inherited;
825end;
826}
827procedure TVA508AccessibilityCollection.RegisterComponent(Component: TWinControl; Item: TVA508AccessibilityItem);
828var
829 key: string;
830begin
831 if ScreenReaderSystemActive then
832 GlobalRegistry.RegisterComponent(Component, FManager);
833 if (not assigned(Component)) or (not assigned(item)) then exit;
834 key := FastIntToHex(Integer(Component));
835 if FRegistry.IndexOf(key) < 0 then
836 begin
837 FRegistry.AddObject(key, Item);
838 Component.FreeNotification(FNotifier);
839 end;
840end;
841
842{ TVA508AccessibilityManager }
843
844constructor TVA508AccessibilityManager.Create(AOwner: TComponent);
845begin
846 inherited Create(AOwner);
847 VA508ComponentCreationCheck(Self, AOwner, FALSE, FALSE);
848 CreateGlobalVars;
849 FData := TVA508AccessibilityCollection.Create(Self);
850 Initialize;
851end;
852
853destructor TVA508AccessibilityManager.Destroy;
854begin
855 VA508ComponentDestructionCheck(Self);
856 if assigned(FData) then
857 FData.Free;
858 if assigned(FDFMData) then
859 FreeAndNil(FDFMData);
860 inherited;
861end;
862
863function TVA508AccessibilityManager.FindComponentOnForm(
864 ComponentName: String): TComponent;
865var
866 p: integer;
867 comp: TComponent;
868 name: String;
869
870 function FindOwnedComponent(AComponent: TComponent; ComponentName: String): TComponent;
871 var
872 i: integer;
873 begin
874 Result := nil;
875 if AnsiCompareText(ComponentName, AComponent.Name)= 0 then
876 begin
877 Result := AComponent;
878 exit;
879 end;
880 for i := 0 to AComponent.ComponentCount - 1 do
881 begin
882 if (AnsiCompareText(ComponentName, AComponent.Components[i].Name)= 0) then
883 begin
884 Result := AComponent.Components[i];
885 exit;
886 end;
887 end;
888 end;
889
890begin
891 if RightStr(ComponentName,1) <> NAME_DELIM then
892 ComponentName := ComponentName + NAME_DELIM;
893 Result := nil;
894 comp := owner;
895 repeat
896 p := pos(NAME_DELIM, ComponentName);
897 if p > 0 then
898 begin
899 name := copy(ComponentName, 1, p-1);
900 delete(ComponentName, 1, p);
901 comp := FindOwnedComponent(comp, name);
902 end;
903 until p = 0;
904 if assigned(comp) then
905 Result := comp;
906end;
907
908function TVA508AccessibilityManager.GetAccessLabel(
909 Component: TWinControl): TLabel;
910begin
911 Result := FData.FindItem(Component).AccessLabel;
912end;
913
914function TVA508AccessibilityManager.GetAccessProperty(
915 Component: TWinControl): String;
916begin
917 Result := FData.FindItem(Component).AccessProperty;
918end;
919
920function TVA508AccessibilityManager.GetAccessText(
921 Component: TWinControl): String;
922begin
923 Result := FData.FindItem(Component).AccessText;
924end;
925
926function TVA508AccessibilityManager.GetComponentManager(
927 Component: TWinControl): TVA508ComponentManager;
928begin
929 Result := FData.FindItem(Component).ComponentManager;
930end;
931
932function TVA508AccessibilityManager.GetComponentName(
933 AComponent: TComponent): String;
934var
935 comp: TComponent;
936
937 procedure error;
938 begin
939 raise EVA508AccessibilityException.Create(INVALID_COMPONENT_ERROR);
940 end;
941
942 function BasicComponentCheck(var Name: string): boolean;
943 begin
944 Result := TRUE;
945 Name := '';
946 if (not assigned(AComponent)) then error;
947 if AComponent = owner then
948 begin
949 Name := AComponent.Name;
950 exit;
951 end;
952 if not assigned(AComponent.Owner) then error;
953 if (AComponent.owner = owner) then
954 Name := AComponent.Name
955 else
956 Result := FALSE;
957 end;
958
959begin
960 if BasicComponentCheck(Result) then exit;
961 comp := AComponent;
962 Result := AComponent.Name;
963 while assigned(comp.Owner) and (comp.Owner <> Owner) do
964 begin
965 comp := comp.Owner;
966 Result := comp.Name + NAME_DELIM + Result;
967 end;
968 if not assigned(comp.Owner) then error;
969end;
970
971function TVA508AccessibilityManager.GetData: TVA508AccessibilityCollection;
972begin
973 Result := FData;
974end;
975
976function TVA508AccessibilityManager.GetDefaultStringProperty(AComponent: TWinControl): String;
977var
978 i: integer;
979 ValuePair: TDefaultStringPropertyValuePair;
980 PropName: string;
981begin
982 Result := '';
983 if not assigned(AComponent) then exit;
984 for i := 1 to CaptionedControlClassCount do
985 begin
986 ValuePair := ControlsWithDefaultPropertySettings[i];
987 if AComponent is ValuePair.ClassType then
988 begin
989 PropName := ValuePair.PublishedPropertyName;
990 if IsPropertyNameValid(AComponent, PropName) then
991 Result := PropName;
992 break;
993 end;
994 end;
995end;
996
997procedure TVA508AccessibilityManager.GetLabelStrings(list: TStringList);
998
999 procedure AddLabels(Component: TWinControl);
1000 var
1001 i: integer;
1002 control: TControl;
1003 begin
1004 for I := 0 to Component.ControlCount-1 do
1005 begin
1006 control := Component.Controls[i];
1007 if control is TLabel then
1008 list.Add(GetComponentName(control) + '="' + TLabel(control).Caption + '"')
1009 else
1010 begin
1011 if (control is TWinControl) and
1012 ((csAcceptsControls in control.ControlStyle) or (control is TFrame)) then
1013 AddLabels(TWinControl(control));
1014 end;
1015 end;
1016 end;
1017
1018begin
1019 AddLabels(TWinControl(Owner));
1020 list.Sort;
1021end;
1022
1023procedure TVA508AccessibilityManager.GetProperties(Component: TWinControl; list: TStrings);
1024begin
1025 list.Assign(GetPropertList(Component));
1026end;
1027
1028function TVA508AccessibilityManager.GetPropertList(Component: TWinControl): TStrings;
1029const
1030// STRING_FILTER = [tkChar, tkString, tkWChar, tkLString, tkWString];
1031 STRING_FILTER = [tkString, tkLString, tkWString];
1032var
1033 pList: PPropList;
1034 i, idx, pCount, pSize: Integer;
1035 ClsInfo: Pointer;
1036 name: string;
1037 info: TStringList;
1038begin
1039 idx := MasterPropertyList.IndexOf(Component.ClassName);
1040 if idx < 0 then
1041 begin
1042 info := TStringList.Create;
1043 try
1044 ClsInfo := Component.ClassInfo;
1045 pCount := GetPropList(ClsInfo, STRING_FILTER, nil);
1046 pSize := pCount * SizeOf(Pointer);
1047 GetMem(pList, pSize);
1048 try
1049 GetPropList(ClsInfo, STRING_FILTER, pList);
1050 for i := 0 to pCount - 1 do
1051 begin
1052 name := pList^[I]^.Name;
1053 if (info.IndexOf(name) < 0) then
1054 info.Add(name);
1055 end;
1056 finally
1057 FreeMem(pList, pSize);
1058 end;
1059 info.Sorted := TRUE;
1060 finally
1061 MasterPropertyList.AddObject(Component.ClassName, info);
1062 end;
1063 end
1064 else
1065 info := TStringList(MasterPropertyList.Objects[idx]);
1066 Result := info;
1067end;
1068
1069function TVA508AccessibilityManager.GetRootComponent(Component: TComponent;
1070 var PropertyName: String): TComponent;
1071var
1072 p: integer;
1073 CompName: string;
1074 root: TObject;
1075
1076begin
1077 Root := Component;
1078 repeat
1079 p := pos(NAME_DELIM, PropertyName);
1080 if p > 0 then
1081 begin
1082 CompName := copy(PropertyName,1,p-1);
1083 delete(PropertyName,1,p);
1084 if IsPublishedProp(root, CompName) then
1085 begin
1086 root := GetObjectProp(root, CompName);
1087 end
1088 else
1089 root := nil;
1090 end;
1091 until (p=0) or (not assigned(root));
1092 if assigned(root) and (root is TComponent) and IsPublishedProp(root, PropertyName) then
1093 Result := TComponent(root)
1094 else
1095 Result := nil;
1096end;
1097
1098function TVA508AccessibilityManager.GetUseDefault(
1099 Component: TWinControl): boolean;
1100begin
1101 Result := FData.FindItem(Component).UseDefault;
1102end;
1103
1104function TVA508AccessibilityManager.IsPropertyNameValid(Component: TWinControl;
1105 PropertyName: String): boolean;
1106var
1107 list: TStrings;
1108begin
1109 if not assigned(Component) then
1110 Result := FALSE
1111 else
1112 begin
1113 list := GetPropertList(Component);
1114 Result := list.IndexOf(PropertyName) >= 0;
1115 end;
1116end;
1117
1118procedure TVA508AccessibilityManager.Loaded;
1119var
1120 i: integer;
1121 data: TDFMData;
1122 component: TComponent;
1123 item: TVA508AccessibilityItem;
1124
1125begin
1126 inherited;
1127 if assigned(FDFMData) then
1128 begin
1129 for i := 0 to FDFMData.Count-1 do
1130 begin
1131 data := TDFMData(FDFMData[i]);
1132 component := FindComponentOnForm(data.ComponentName);
1133 if assigned(component) and (component is TWinControl) then
1134 begin
1135 item := FData.FindItem(TWinControl(component));
1136 if data.LabelName <> '' then
1137 begin
1138 component := FindComponentOnForm(data.LabelName);
1139 if assigned(component) and (component is TLabel) then
1140 item.AccessLabel := TLabel(component);
1141 end;
1142 if data.PropertyName <> '' then
1143 item.AccessProperty := data.PropertyName;
1144 if data.Text <> '' then
1145 item.AccessText := data.Text;
1146 if data.Status = stsDefault then
1147 item.UseDefault := TRUE;
1148 end;
1149 end;
1150 FData.EnsureItemExists(TWinControl(Owner));
1151 FreeAndNil(FDFMData);
1152 end;
1153 if not (csDesigning in ComponentState) then
1154 Initialize;
1155end;
1156
1157procedure TVA508AccessibilityManager.Notification(AComponent: TComponent;
1158 Operation: TOperation);
1159
1160 procedure UpdateComponent(Component: TWinControl; Adding: boolean);
1161 var
1162 i: integer;
1163 Control : TWinControl;
1164 item: TVA508AccessibilityItem;
1165 begin
1166 if Adding then
1167 FData.EnsureItemExists(Component)
1168 else
1169 begin
1170 item := FData.FindItem(Component, FALSE);
1171 if assigned(item) then
1172 item.Free;
1173 end;
1174 if (csAcceptsControls in Component.ControlStyle) then
1175 begin
1176 for I := 0 to Component.ControlCount - 1 do
1177 begin
1178 if Component.Controls[I] is TWinControl then
1179 begin
1180 Control := TWinControl(Component.Controls[I]);
1181 if OwnerCheck(Control) then
1182 UpdateComponent(Control, Adding);
1183 end;
1184 end;
1185 end;
1186 end;
1187
1188begin
1189 inherited Notification(AComponent, Operation);
1190 if (not assigned(AComponent)) or (not (AComponent is TWinControl)) or
1191 (csDestroying in ComponentState) then exit;
1192 if Operation = opInsert then
1193 UpdateComponent(TWinControl(AComponent), TRUE)
1194 else
1195 UpdateComponent(TWinControl(AComponent), FALSE);
1196end;
1197
1198function TVA508AccessibilityManager.OwnerCheck(Component: TComponent): boolean;
1199var
1200 root: TComponent;
1201begin
1202 Result := false;
1203 root := component;
1204 while assigned(root) do
1205 begin
1206 if root = owner then
1207 begin
1208 Result := true;
1209 exit;
1210 end;
1211 root := root.Owner;
1212 end;
1213end;
1214
1215procedure TVA508AccessibilityManager.DefineProperties(Filer: TFiler);
1216begin
1217 inherited DefineProperties(Filer);
1218 Filer.DefineProperty(VA508DFMDataPropertyName, ReadData, WriteData, TRUE);
1219end;
1220
1221procedure TVA508AccessibilityManager.ReadData(Reader: TReader);
1222var
1223 data: TDFMData;
1224 line: string;
1225 name, value: string;
1226 idx: integer;
1227
1228begin
1229 FData.Clear;
1230 if assigned(FDFMData) then
1231 FDFMData.Clear
1232 else
1233 FDFMData := TObjectList.Create;
1234 Reader.ReadListBegin;
1235 try
1236 while not Reader.EndOfList do
1237 begin
1238 Reader.ReadListBegin;
1239 try
1240 data := TDFMData.Create;
1241 FDFMData.Add(data);
1242 while not Reader.EndOfList do
1243 begin
1244 line := Reader.ReadString;
1245 idx := pos(EQU, line);
1246 if idx > 0 then
1247 begin
1248 name := copy(line,1,idx-1);
1249 value := copy(line, idx+EQU_LEN, MaxInt);
1250 if name = AccessDataComponentText then
1251 data.ComponentName := value
1252 else if name = AccessDataLabelText then
1253 data.LabelName := value
1254 else if name = AccessDataPropertyText then
1255 data.PropertyName := value
1256 else if name = AccessDataTextText then
1257 data.Text := value
1258 else if name = AccessDataStatusText then
1259 data.Status := TVA508AccessibilityStatus(GetEnumValue(
1260 TypeInfo(TVA508AccessibilityStatus), value));
1261 end;
1262 end;
1263 finally
1264 Reader.ReadListEnd
1265 end;
1266 end;
1267 finally
1268 Reader.ReadListEnd;
1269 end;
1270end;
1271
1272procedure TVA508AccessibilityManager.RefreshComponents;
1273begin
1274 Initialize;
1275end;
1276
1277procedure TVA508AccessibilityManager.WriteData(Writer: TWriter);
1278var
1279 i: integer;
1280 item: TVA508AccessibilityItem;
1281
1282begin
1283// ??????????????????
1284// for i := FData.Count-1 downto 0 do
1285// begin
1286// if not assigned(FData.Items[i].Component) then
1287// FData.Delete(i);
1288// end;
1289
1290 Writer.WriteListBegin;
1291 try
1292 for i := 0 to FData.Count - 1 do
1293 begin
1294 item := FData.Items[i];
1295 if assigned(item.Component) then
1296 begin
1297 item.UpdateStatus;
1298 Writer.WriteListBegin;
1299 try
1300 Writer.WriteString(AccessDataComponentText + EQU +
1301 GetComponentName(item.Component));
1302 if assigned(item.AccessLabel) then
1303 Writer.WriteString(AccessDataLabelText + EQU +
1304 GetComponentName(item.AccessLabel));
1305 if item.AccessProperty <> '' then
1306 Writer.WriteString(AccessDataPropertyText + EQU + item.AccessProperty);
1307 if item.AccessText <> '' then
1308 Writer.WriteString(AccessDataTextText + EQU + item.AccessText);
1309 Writer.WriteString(AccessDataStatusText + EQU +
1310 GetEnumName(TypeInfo(TVA508AccessibilityStatus), ord(item.Status)));
1311 finally
1312 Writer.WriteListEnd;
1313 end;
1314 end;
1315 end;
1316 finally
1317 Writer.WriteListEnd;
1318 end;
1319end;
1320
1321type
1322 AccessComponent = class(TWinControl);
1323
1324function TVA508AccessibilityManager.ScreenReaderInquiry(
1325 Component: TWinControl): string;
1326var
1327 item: TVA508AccessibilityItem;
1328 prop: string;
1329 comp: TComponent;
1330 DynaComp: IVADynamicProperty;
1331
1332begin
1333 Result := '';
1334 item := FData.FindItem(Component);
1335
1336 if item.UseDefault then
1337 begin
1338 if AccessComponent(Component).QueryInterface(IVADynamicProperty,DynaComp) = S_OK then
1339 begin
1340 try
1341 if DynaComp.SupportsDynamicProperty(DynaPropAccesibilityCaption) then
1342 Result := DynaComp.GetDynamicProperty(DynaPropAccesibilityCaption);
1343 finally
1344 DynaComp := nil;
1345 end;
1346 end;
1347 end
1348 else
1349 begin
1350 if assigned(item.AccessLabel) then
1351 Result := item.AccessLabel.Caption
1352 else if item.AccessText <> '' then
1353 Result := item.AccessText
1354 else
1355 begin
1356 prop := item.AccessProperty;
1357 if prop <> '' then
1358 begin
1359 comp := GetRootComponent(Component, prop);
1360 if assigned(comp) then
1361 Result := GetPropValue(comp, prop);
1362 end;
1363 end;
1364 end;
1365end;
1366
1367procedure TVA508AccessibilityManager.SetAccessLabel(Component: TWinControl;
1368 const Value: TLabel);
1369begin
1370 FData.FindItem(Component).AccessLabel := Value;
1371end;
1372
1373procedure TVA508AccessibilityManager.SetAccessProperty(Component: TWinControl;
1374 const Value: String);
1375begin
1376 FData.FindItem(Component).AccessProperty := Value;
1377end;
1378
1379procedure TVA508AccessibilityManager.SetAccessText(Component: TWinControl;
1380 const Value: String);
1381begin
1382 FData.FindItem(Component).AccessText := Value;
1383end;
1384
1385procedure TVA508AccessibilityManager.SetComponentManager(Component: TWinControl;
1386 const Value: TVA508ComponentManager);
1387begin
1388 FData.FindItem(Component).ComponentManager := Value;
1389end;
1390
1391procedure TVA508AccessibilityManager.SetUseDefault(Component: TWinControl;
1392 const Value: boolean);
1393begin
1394 FData.FindItem(Component).UseDefault := Value;
1395end;
1396
1397procedure TVA508AccessibilityManager.Initialize;
1398var
1399 list: TList;
1400 i, idx: integer;
1401 control: TWinControl;
1402 item: TVA508AccessibilityItem;
1403
1404 procedure Update(Component: TWinControl);
1405 var
1406 i: integer;
1407 begin
1408 if (not assigned(Component.Parent)) or (csAcceptsControls in Component.Parent.ControlStyle) then
1409 list.add(Component);
1410 for I := 0 to Component.ControlCount - 1 do
1411 begin
1412 if Component.Controls[I] is TWinControl then
1413 begin
1414 Control := TWinControl(Component.Controls[I]);
1415 if (not assigned(Control.Owner)) or OwnerCheck(Control) then
1416 Update(Control);
1417 end;
1418 end;
1419 end;
1420
1421begin
1422 list := TList.Create;
1423 try
1424 if (Owner is TWinControl) and ([csLoading, csDesignInstance] * Owner.ComponentState = []) then
1425 Update(TWinControl(Owner));
1426 for I := FData.Count - 1 downto 0 do
1427 begin
1428 item := FData[i];
1429
1430 if assigned(item.Component) then
1431 begin
1432 idx := list.IndexOf(item.Component);
1433 if idx < 0 then
1434 item.Free
1435 else
1436 list.delete(idx);
1437 end
1438 else
1439 item.free;
1440 end;
1441 for I := 0 to List.Count - 1 do
1442 begin
1443 FData.EnsureItemExists(TWinControl(list[i]));
1444 end;
1445 finally
1446 list.free;
1447 end;
1448end;
1449
1450{ Registration }
1451type
1452 TAlternateHandleData = class
1453 ComponentClass: TWinControlClass;
1454 GetHandle: TVA508AlternateHandleFunc;
1455 end;
1456
1457procedure RegisterAlternateHandleComponent(ComponentClass: TWinControlClass;
1458 AlternateHandleFunc: TVA508AlternateHandleFunc);
1459var
1460 data: TAlternateHandleData;
1461 i: integer;
1462begin
1463 if not ScreenReaderSystemActive then exit;
1464 if not assigned(AltHandleClasses) then
1465 AltHandleClasses := TObjectList.Create
1466 else
1467 begin
1468 for i := 0 to AltHandleClasses.Count - 1 do
1469 begin
1470 data := TAlternateHandleData(AltHandleClasses[i]);
1471 if ComponentClass = data.ComponentClass then exit;
1472 end;
1473 end;
1474 data := TAlternateHandleData.Create;
1475 data.ComponentClass := ComponentClass;
1476 data.GetHandle := AlternateHandleFunc;
1477 AltHandleClasses.Add(data);
1478end;
1479
1480procedure RegisterComplexComponentManager(Manager: TVA508ComplexComponentManager);
1481var
1482 data: TVA508ComplexComponentManager;
1483 i: integer;
1484begin
1485 if ScreenReaderSystemActive then
1486 begin
1487 if not assigned(ComplexClasses) then
1488 ComplexClasses := TObjectList.Create
1489 else
1490 begin
1491 for i := 0 to ComplexClasses.Count - 1 do
1492 begin
1493 data := TVA508ComplexComponentManager(ComplexClasses[i]);
1494 if data.ComponentClass = Manager.ComponentClass then
1495 begin
1496 Manager.Free;
1497 exit;
1498 end;
1499 end;
1500 end;
1501 ComplexClasses.Add(Manager);
1502 end
1503 else
1504 Manager.Free;
1505end;
1506
1507procedure RegisterManagedComponentClass(Manager: TVA508ManagedComponentClass);
1508var
1509 data: TVA508ManagedComponentClass;
1510 i: integer;
1511begin
1512 if ScreenReaderSystemActive then
1513 begin
1514 if not assigned(ManagedClasses) then
1515 ManagedClasses := TObjectList.Create
1516 else
1517 begin
1518 for i := 0 to ManagedClasses.Count - 1 do
1519 begin
1520 data := TVA508ManagedComponentClass(ManagedClasses[i]);
1521 if Manager.ComponentClassType = data.ComponentClassType then
1522 begin
1523 if Manager <> data then
1524 Manager.Free;
1525 exit;
1526 end;
1527 end;
1528 end;
1529 ManagedClasses.Add(Manager);
1530 end
1531 else
1532 Manager.Free;
1533end;
1534
1535function FindMSAAQueryData(MSAAClass: TWinControlClass): TMSAAData;
1536var
1537 i: integer;
1538begin
1539 Result := nil;
1540 if not assigned(MSAAQueryClasses) then exit;
1541 for i := 0 to MSAAQueryClasses.Count - 1 do
1542 begin
1543 Result := TMSAAData(MSAAQueryClasses[i]);
1544 if MSAAClass.InheritsFrom(Result.MSAAClass) then exit;
1545 end;
1546 Result := nil;
1547end;
1548
1549procedure RegisterMSAAProc(MSAAClass: TWinControlClass;
1550 Proc: TVA508QueryProc; ListProc: TVA508ListQueryProc);
1551var
1552 Data: TMSAAData;
1553begin
1554 if not assigned(MSAAQueryClasses) then
1555 MSAAQueryClasses := TObjectList.Create;
1556 Data := FindMSAAQueryData(MSAAClass);
1557 if not assigned(Data) then
1558 begin
1559 Data := TMSAAData.Create;
1560 Data.MSAAClass := MSAAClass;
1561 Data.Proc := Proc;
1562 Data.ListProc := ListProc;
1563 MSAAQueryClasses.Add(Data);
1564 end;
1565end;
1566
1567procedure RegisterMSAAQueryClassProc(MSAAClass: TWinControlClass; Proc: TVA508QueryProc);
1568begin
1569 RegisterMSAAProc(MSAAClass, Proc, nil);
1570end;
1571
1572procedure RegisterMSAAQueryListClassProc(MSAAClass: TWinControlClass; Proc: TVA508ListQueryProc);
1573begin
1574 RegisterMSAAProc(MSAAClass, nil, Proc);
1575end;
1576
1577{ TVAGlobalComponentRegistry }
1578
1579procedure TVAGlobalComponentRegistry.CheckForChangeEvent;
1580var
1581 Helper: TComponentHelper;
1582 NewCaption: string;
1583 NewState: string;
1584
1585 NewItem: TObject;
1586 SendData: boolean;
1587 CheckState: boolean;
1588 DataResult: LongInt;
1589 DataStatus: LongInt;
1590 NewItemInstructions: string;
1591 Temp: string;
1592
1593 Caption: PChar;
1594 Value: PChar;
1595 Data: PChar;
1596 ControlType: PChar;
1597 State: PChar;
1598 Instructions: PChar;
1599 ItemInstructions: PChar;
1600
1601 function HandleStillValid: boolean;
1602 begin
1603 Result := IsWindow(FComponentData.Handle) and IsWindowVisible(FComponentData.Handle);
1604 end;
1605
1606 function NoChangeNeeded: boolean;
1607 begin
1608 Result := TRUE;
1609 if not assigned(SRComponentData) then exit;
1610 if not assigned(SRConfigChangePending) then exit;
1611 if FComponentData.Handle = 0 then exit;
1612 Helper := GetComponentHelper(FComponentData.Handle);
1613 if not assigned(Helper) then exit;
1614 Helper.InitializeComponentManager;
1615 if Helper.StandardComponent then exit;
1616 if SRConfigChangePending then exit;
1617 Result := FALSE;
1618 end;
1619
1620 procedure Init;
1621 begin
1622 DataResult := DATA_NONE;
1623 DataStatus := DATA_NONE;
1624 Caption := nil;
1625 Value := nil;
1626 Data := nil;
1627 ControlType := nil;
1628 State := nil;
1629 Instructions := nil;
1630 ItemInstructions := nil;
1631 CheckState := TRUE;
1632 end;
1633
1634 procedure ProcessCaptionChange;
1635 begin
1636 if FComponentData.CaptionQueried and Helper.ManageCaption then
1637 begin
1638 NewCaption := Helper.GetCaption(DataResult);
1639 if (FComponentData.Caption <> NewCaption) then
1640 begin
1641 FComponentData.Caption := NewCaption;
1642 if ((DataResult and DATA_CAPTION) <> 0) then
1643 begin
1644 DataStatus := DataStatus OR DATA_CAPTION;
1645 Caption := PChar(NewCaption);
1646 end;
1647 end;
1648 end;
1649 end;
1650
1651 procedure ProcessItemChange;
1652 var
1653 TempValue: string;
1654 begin
1655 if FComponentData.ValueQueried and Helper.MonitorForItemChange then
1656 begin
1657 NewItem := Helper.GetItem;
1658 if (FComponentData.Item <> NewItem) then
1659 begin
1660 FComponentData.Item := NewItem;
1661 CheckState := FALSE;
1662 SendData := FALSE;
1663
1664 if Helper.ManageValue then
1665 begin
1666 Value := PChar(Helper.GetValue(DataResult));
1667 if (DataResult AND DATA_VALUE) <> 0 then
1668 begin
1669 SendData := TRUE;
1670 DataStatus := DataStatus OR DATA_VALUE;
1671 end;
1672 end;
1673
1674 if Helper.ManageData then
1675 begin
1676 if Helper.ManageValue then
1677 TempValue := Value
1678 else
1679 TempValue := '';
1680 Data := PChar(Helper.GetData(DataResult, Value));
1681 if (DataResult AND DATA_DATA) <> 0 then
1682 begin
1683 SendData := TRUE;
1684 DataStatus := DataStatus OR DATA_DATA;
1685 end;
1686 end;
1687
1688 if FComponentData.StateQueried and Helper.MonitorForStateChange then
1689 begin
1690 NewState := Helper.GetState(DataResult);
1691 if FComponentData.State <> NewState then
1692 FComponentData.State := NewState;
1693 if (DataResult AND DATA_STATE) <> 0 then
1694 begin
1695 State := PChar(NewState);
1696 SendData := TRUE;
1697 DataStatus := DataStatus OR DATA_STATE;
1698 if FComponentData.ItemInstrQueried and Helper.ManageItemInstructions then
1699 begin
1700 NewItemInstructions := Helper.GetItemInstructions(DataResult);
1701 if NewItemInstructions <> '' then
1702 begin
1703 temp := IIDelim + NewItemInstructions + IIDelim;
1704 if pos(temp, FComponentData.ItemInstructions) < 1 then
1705 begin
1706 FComponentData.ItemInstructions := FComponentData.ItemInstructions + NewItemInstructions + IIDelim;
1707 ItemInstructions := PChar(NewItemInstructions);
1708 if (DataResult AND DATA_ITEM_INSTRUCTIONS) <> 0 then
1709 DataStatus := DataStatus OR DATA_ITEM_INSTRUCTIONS;
1710 end;
1711 end;
1712 end;
1713 end;
1714 end;
1715 if SendData then
1716 DataStatus := DataStatus OR DATA_ITEM_CHANGED;
1717 end;
1718 end;
1719 end;
1720
1721 procedure ProcessStateChange;
1722 begin
1723 if CheckState and FComponentData.StateQueried and Helper.MonitorForStateChange then
1724 begin
1725 NewState := Helper.GetState(DataResult);
1726 if FComponentData.State <> NewState then
1727 begin
1728 FComponentData.State := NewState;
1729 if (DataResult AND DATA_STATE) <> 0 then
1730 begin
1731 State := PChar(NewState);
1732 DataStatus := DataStatus OR DATA_STATE;
1733 end;
1734 end;
1735 end;
1736 end;
1737
1738 procedure AddControlType;
1739 begin
1740 if (DataStatus <> DATA_NONE) and Helper.ManageComponentName then
1741 begin
1742 ControlType := PChar(Helper.GetComponentName(DataResult));
1743 if (DataResult AND DATA_CONTROL_TYPE) <> 0 then
1744 begin
1745 DataStatus := DataStatus OR DATA_CONTROL_TYPE;
1746 end;
1747 end;
1748 end;
1749
1750 procedure SendChangeData;
1751 begin
1752 if (DataStatus <> DATA_NONE) then
1753 begin
1754 DataStatus := DataStatus OR DATA_CHANGE_EVENT;
1755 SRComponentData(FComponentData.Handle, DataStatus, Caption, Value, Data, ControlType,
1756 State, Instructions, ItemInstructions);
1757 end;
1758 end;
1759
1760begin
1761 if NoChangeNeeded then
1762 begin
1763 exit;
1764 end;
1765 // HandleStillValid needed because reminders destroy check boxes from underneath us
1766 if HandleStillValid then Init;
1767 if HandleStillValid then ProcessCaptionChange;
1768 if HandleStillValid then ProcessItemChange;
1769 if HandleStillValid then ProcessStateChange;
1770 if HandleStillValid then AddControlType;
1771 if HandleStillValid then SendChangeData;
1772end;
1773
1774
1775procedure TVAGlobalComponentRegistry.ComponentDataNeededEvent(const WindowHandle: HWND;
1776 var DataStatus: LongInt; var Caption: PChar; var Value: PChar; var Data: PChar;
1777 var ControlType: PChar; var State: PChar; var Instructions: PChar; var ItemInstructions: PChar);
1778var
1779 DataResult: LongInt;
1780 UseCaption: boolean;
1781 UseValue: boolean;
1782 UseControlType: boolean;
1783 UseState: boolean;
1784 UseInstructions: boolean;
1785 UseItemInstructions: boolean;
1786 NewCaption: string;
1787 NewState: string;
1788 NewItemInstructions: string;
1789 NewValue: string;
1790 NewData: string;
1791 NewInstructions: string;
1792 NewControlType: string;
1793 Component: TWinControl;
1794 HelperInvalid: boolean;
1795 Done: boolean;
1796 temp: string;
1797
1798 function HelperValid: boolean;
1799 begin
1800 if HelperInvalid then
1801 begin
1802 Result := FALSE;
1803 exit;
1804 end;
1805 try
1806 Result := assigned(FCurrentHelper) and
1807 assigned(FCurrentHelper.FComponent) and
1808 IsWindow(FCurrentHelper.FComponent.Handle) and
1809 IsWindowVisible(FCurrentHelper.FComponent.Handle);
1810 except
1811 Result := FALSE;
1812 end;
1813 if not Result then
1814 begin
1815 HelperInvalid := TRUE;
1816 end;
1817 end;
1818
1819 procedure UpdateComponentData;
1820 begin
1821 if (FComponentData.Handle = WindowHandle) then
1822 begin
1823 if UseCaption then
1824 begin
1825 FComponentData.CaptionQueried := TRUE;
1826 FComponentData.Caption := NewCaption;
1827 end;
1828 if UseValue then
1829 begin
1830 FComponentData.ValueQueried := TRUE;
1831 if FCurrentHelper.MonitorForItemChange and HelperValid then
1832 FComponentData.Item := FCurrentHelper.GetItem;
1833 end;
1834 if UseState then
1835 begin
1836 FComponentData.StateQueried := TRUE;
1837 FComponentData.State := NewState;
1838 end;
1839 if UseItemInstructions then
1840 begin
1841 FComponentData.ItemInstrQueried := TRUE;
1842 FComponentData.ItemInstructions := IIDelim + NewItemInstructions + IIDelim;
1843 end;
1844 end;
1845 end;
1846
1847 procedure InitializeVars;
1848 begin
1849 DataResult := DATA_NONE;
1850 UseCaption := ((DataStatus and DATA_CAPTION) <> 0);
1851 UseValue := ((DataStatus and DATA_VALUE) <> 0);
1852 UseControlType := ((DataStatus and DATA_CONTROL_TYPE) <> 0);
1853 UseState := ((DataStatus and DATA_STATE) <> 0);
1854 UseInstructions := ((DataStatus and DATA_INSTRUCTIONS) <> 0);
1855 UseItemInstructions := ((DataStatus and DATA_ITEM_INSTRUCTIONS) <> 0);
1856
1857 NewCaption := '';
1858 NewState := '';
1859 NewItemInstructions := '';
1860
1861 if HelperValid then FCurrentHelper.InitializeComponentManager;
1862 end;
1863
1864 procedure GetDataValues;
1865 begin
1866 if UseCaption and HelperValid then
1867 begin
1868 NewCaption := FCurrentHelper.GetCaption(DataResult);
1869 Caption := PChar(NewCaption);
1870 end;
1871
1872 if UseValue and HelperValid then
1873 begin
1874 //PChars are pointers - must point to string - if point to function thier values change unpredictably
1875 NewValue := FCurrentHelper.GetValue(DataResult);
1876 Value := PChar(NewValue);
1877 NewData := FCurrentHelper.GetData(DataResult, NewValue);
1878 Data := PChar(NewData);
1879 end;
1880
1881 if UseControlType and HelperValid then
1882 begin
1883 NewControlType := FCurrentHelper.GetComponentName(DataResult);
1884 ControlType := PChar(NewControlType);
1885 end;
1886
1887 if UseState and HelperValid then
1888 begin
1889 NewState := FCurrentHelper.GetState(DataResult);
1890 State := PChar(NewState);
1891 end;
1892
1893 if UseInstructions and HelperValid then
1894 begin
1895 NewInstructions := FCurrentHelper.GetInstructions(DataResult);
1896 Instructions := PChar(NewInstructions);
1897 end;
1898
1899 if UseItemInstructions and HelperValid then
1900 begin
1901 NewItemInstructions := FCurrentHelper.GetItemInstructions(DataResult);
1902 ItemInstructions := PChar(NewItemInstructions);
1903 end;
1904 end;
1905
1906begin
1907 if FDestroying then exit;
1908 if (FComponentData.Handle <> WindowHandle) then
1909 begin
1910 FComponentData := NewComponentData;
1911 FComponentData.Handle := WindowHandle;
1912 end;
1913
1914 HelperInvalid := FALSE;
1915 FCurrentHelper := GetComponentHelper(WindowHandle);
1916 if not assigned(FCurrentHelper) then
1917 DataResult := DATA_ERROR
1918 else
1919 begin
1920 if HelperValid then
1921 begin
1922 try
1923 repeat
1924 Done := TRUE;
1925 if HelperValid then
1926 Component := FCurrentHelper.FComponent
1927 else
1928 Component := nil;
1929 if HelperValid then InitializeVars;
1930 if HelperValid then temp := FCurrentHelper.Component.ClassName;
1931 if HelperValid then GetDataValues;
1932 if HelperValid then UpdateComponentData;
1933 if (not assigned(FCurrentHelper)) and assigned(Component) then
1934 begin
1935 try
1936 FCurrentHelper := GetComponentHelper(Component.Handle);
1937 Done := FALSE;
1938 HelperInvalid := FALSE;
1939 except
1940 end;
1941 end;
1942 until Done;
1943 finally
1944 FCurrentHelper := nil;
1945 end;
1946 if HelperInvalid and (DataResult = DATA_NONE) then
1947 DataResult := DATA_ERROR;
1948 end
1949 else
1950 begin
1951 FCurrentHelper := nil;
1952 DataResult := DATA_ERROR;
1953 end;
1954 end;
1955 DataStatus := DataResult;
1956end;
1957
1958var
1959 CanAssignFocus: boolean = TRUE;
1960
1961var
1962 CanCheckEvent: boolean = TRUE;
1963
1964function GetMessageHookProc(Code: Integer; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall;
1965var
1966 pMessage: PMsg;
1967 msg: UINT;
1968
1969begin
1970 if CanCheckEvent then
1971 begin
1972 CanCheckEvent := FALSE;
1973 try
1974 if TVAGlobalComponentRegistry.FActive and (code >= 0) then
1975 begin
1976 pMessage := pointer(lParam);
1977 msg := pMessage^.message and $ffff;
1978 case msg of
1979 WM_KEYFIRST .. WM_KEYLAST,
1980 (WM_MOUSEFIRST + 1) .. WM_MOUSELAST: // WM_MOUSEFIRST = WM_MOUSEMOVE
1981 GlobalRegistry.CheckForChangeEvent;
1982 end;
1983 end;
1984 finally
1985 CanCheckEvent := TRUE;
1986 end;
1987 end;
1988 Result := CallNextHookEx(TVAGlobalComponentRegistry.FGetMsgHookHandle, Code, wParam, lParam);
1989end;
1990
1991constructor TVAGlobalComponentRegistry.Create;
1992begin
1993 FPendingFieldObjects := TStringList.Create;
1994 FComponentRegistry := TStringList.Create;
1995 FComponentRegistry.Duplicates := dupAccept;
1996 FComponentRegistry.Sorted := TRUE;
1997 FHandlesXREF := TStringList.Create;
1998 FHandlesXREF.Duplicates := dupAccept;
1999 FHandlesXREF.Sorted := TRUE;
2000 FHandlesPending := TStringList.Create;
2001 FPendingRecheckTimer := TTimer.Create(nil);
2002 FPendingRecheckTimer.Enabled := FALSE;
2003 FPendingRecheckTimer.OnTimer := TimerEvent;
2004 FPendingRecheckTimer.Interval := 500;
2005 FComponentData := NewComponentData;
2006 FGetMsgHookHandle := SetWindowsHookEx(WH_GETMESSAGE, GetMessageHookProc, 0, GetCurrentThreadID);
2007 TVA508RegistrationScreenReader(GetScreenReader).
2008 AddComponentDataNeededEventHandler(ComponentDataNeededEvent);
2009 FActive := TRUE;
2010end;
2011
2012destructor TVAGlobalComponentRegistry.Destroy;
2013begin
2014 FDestroying := TRUE;
2015 FActive := FALSE;
2016 TVA508RegistrationScreenReader(GetScreenReader).RemoveComponentDataNeededEventHandler(ComponentDataNeededEvent);
2017 UnhookWindowsHookEx(FGetMsgHookHandle);
2018 FreeAndNil(FPendingRecheckTimer);
2019 FreeAndNil(FHandlesPending);
2020 FreeAndNil(FHandlesXREF);
2021 FreeAndNil(FPendingFieldObjects);
2022 FreeAndNilTStringsAndObjects(FComponentRegistry);
2023 inherited;
2024end;
2025
2026function TVAGlobalComponentRegistry.GetCompKey(Component: TWinControl): String;
2027begin
2028 Result := FastIntToHex(Integer(Component));
2029end;
2030
2031function TVAGlobalComponentRegistry.GetComponentHandle(Component: TWinControl): Hwnd;
2032var
2033 i: integer;
2034 UseDefault: boolean;
2035 data: TAlternateHandleData;
2036 ok: boolean;
2037begin
2038 Result := 0;
2039 ok := Component.Visible;
2040 if ok then
2041 begin
2042 ok := Component is TCustomForm;
2043 if not ok then
2044 begin
2045 ok := assigned(Component.parent);
2046 if ok then
2047 ok := Component.parent.Visible;
2048 end;
2049 end;
2050 if ok then
2051 begin
2052 UseDefault := TRUE;
2053 if assigned(AltHandleClasses) then
2054 begin
2055 for i := 0 to AltHandleClasses.Count-1 do
2056 begin
2057 data := TAlternateHandleData(AltHandleClasses[i]);
2058 if Component.InheritsFrom(data.ComponentClass) then
2059 begin
2060 UseDefault := FALSE;
2061 Result := data.GetHandle(Component);
2062 end;
2063 end;
2064 end;
2065 if UseDefault then
2066 begin
2067 try
2068 Result := Component.Handle
2069 except
2070 Result := 0;
2071 end;
2072 end;
2073 end;
2074end;
2075
2076function TVAGlobalComponentRegistry.GetFieldObject(Component: TWinControl): TVA508ComponentAccessibility;
2077var
2078 idx: integer;
2079 compKey: string;
2080begin
2081 compKey := GetCompKey(component);
2082 idx := FComponentRegistry.IndexOf(compkey);
2083 if idx < 0 then
2084 begin
2085 idx := FPendingFieldObjects.IndexOf(compKey);
2086 if idx < 0 then
2087 Result := nil
2088 else
2089 Result := TVA508ComponentAccessibility(FPendingFieldObjects.Objects[idx]);
2090 end
2091 else
2092 Result := TComponentHelper(FComponentRegistry.Objects[idx]).FieldObject;
2093end;
2094
2095function TVAGlobalComponentRegistry.GetComponentHelper(WindowHandle: HWND): TComponentHelper;
2096var
2097 key: string;
2098 idx: integer;
2099 Recheck: boolean;
2100begin
2101 Result := nil;
2102 if IsWindow(WindowHandle) and IsWindowVisible(WindowHandle) then
2103 begin
2104 key := FastIntToHex(WindowHandle);
2105 idx := FHandlesXREF.IndexOf(key);
2106 if idx < 0 then
2107 begin
2108 UpdateHandles(WindowHandle, Recheck);
2109 if Recheck then
2110 idx := FHandlesXREF.IndexOf(key);
2111 end;
2112 if idx >= 0 then
2113 begin
2114 Result := TComponentHelper(FHandlesXREF.Objects[idx]);
2115 end;
2116 end;
2117end;
2118
2119function TVAGlobalComponentRegistry.HasHandle(Component: TWinControl;
2120 var HandleKey: String): boolean;
2121begin
2122 Result := FALSE;
2123 HandleKey := '';
2124 if FDestroying then exit;
2125 try
2126 if Component.Visible and ((Component.Parent <> nil) or (Component is TCustomForm)) then
2127 HandleKey := FastIntToHex(GetComponentHandle(Component));
2128 except
2129 HandleKey := '';
2130 end;
2131 Result := (HandleKey <> '') and (HandleKey <> '00000000');
2132end;
2133
2134procedure TVAGlobalComponentRegistry.RegisterFieldObject(
2135 Component: TWinControl; FieldObject: TVA508ComponentAccessibility;
2136 Adding: boolean);
2137var
2138 idx: integer;
2139 compKey: string;
2140 Helper: TComponentHelper;
2141
2142begin
2143 if FDestroying or (not assigned(Component)) then exit;
2144 compKey := GetCompKey(component);
2145 idx := FComponentRegistry.IndexOf(compkey);
2146 if idx < 0 then
2147 begin
2148 if Adding then
2149 begin
2150 if FPendingFieldObjects.IndexOf(CompKey) < 0 then
2151 FPendingFieldObjects.AddObject(compKey, FieldObject)
2152 end
2153 else
2154 begin
2155 idx := FPendingFieldObjects.IndexOf(CompKey);
2156 if idx >= 0 then
2157 FPendingFieldObjects.Delete(idx);
2158 end;
2159 end
2160 else
2161 begin
2162 Helper := TComponentHelper(FComponentRegistry.Objects[idx]);
2163 if Adding then
2164 Helper.FieldObject := FieldObject
2165 else
2166 Helper.FieldObject := nil;
2167 end;
2168end;
2169
2170procedure TVAGlobalComponentRegistry.RegisterMSAA(Component: TWinControl);
2171var
2172 Data: TMSAAData;
2173begin
2174 if Component.InheritsFrom(TWinControl) then
2175 begin
2176 Data := FindMSAAQueryData(TWinControlClass(Component.ClassType));
2177 if assigned(Data) then
2178 begin
2179 if assigned(data.Proc) then
2180 RegisterMSAAComponentQueryProc(Component, Data.Proc)
2181 else
2182 RegisterMSAAComponentListQueryProc(Component, Data.ListProc)
2183 end;
2184 end;
2185end;
2186
2187procedure TVAGlobalComponentRegistry.RegisterComponent(
2188 component: TWinControl; Manager: TVA508AccessibilityManager);
2189var
2190 Helper: TComponentHelper;
2191 compKey, handleKey: string;
2192
2193 procedure CheckManagedClasses;
2194 var
2195 cls: TClass;
2196 pass: integer;
2197 i: integer;
2198 mData: TVA508ManagedComponentClass;
2199 found, ok: boolean;
2200 begin
2201 if assigned(ManagedClasses) then
2202 begin
2203 cls := Component.ClassType;
2204 found := FALSE;
2205 for pass := 0 to 1 do
2206 begin
2207 for i := 0 to ManagedClasses.Count - 1 do
2208 begin
2209 mData := TVA508ManagedComponentClass(ManagedClasses[i]);
2210 if mData.ManageDescendentClasses then
2211 begin
2212 if (pass = 1) then
2213 ok := cls.InheritsFrom(mData.ComponentClassType)
2214 else
2215 ok := false;
2216 end
2217 else
2218 begin
2219 if (pass = 0) then
2220 ok := (mData.ComponentClassType = cls)
2221 else
2222 ok := false;
2223 end;
2224 if ok then
2225 begin
2226 Helper.ManagedClassData := mData;
2227 found := TRUE;
2228 break;
2229 end;
2230 end;
2231 if found then
2232 break;
2233 end;
2234 end;
2235 end;
2236
2237 procedure CheckComplexClasses;
2238 var
2239 cls: TClass;
2240 i: integer;
2241 mgr: TVA508ComplexComponentManager;
2242 begin
2243 if assigned(ComplexClasses) then
2244 begin
2245 cls := Component.ClassType;
2246 for i := 0 to ComplexClasses.Count - 1 do
2247 begin
2248 mgr := TVA508ComplexComponentManager(ComplexClasses[i]);
2249 if cls.InheritsFrom(mgr.ComponentClass) then
2250 begin
2251 Helper.ComplexManager := mgr;
2252 mgr.Refresh(Component, Manager);
2253 break;
2254 end;
2255 end;
2256 end;
2257 end;
2258
2259 procedure CreateHelper; //TVA508ComplexComponentManager(ComplexClasses[i]);
2260 var
2261 idx: integer;
2262 begin
2263 Helper := TComponentHelper.Create;
2264 Helper.Component := Component;
2265 Helper.Manager := Manager;
2266 Helper.ManagedClassData := nil;
2267 CheckComplexClasses;
2268 CheckManagedClasses;
2269 idx := FPendingFieldObjects.IndexOf(compKey);
2270 if idx >= 0 then
2271 begin
2272 Helper.FieldObject := TVA508ComponentAccessibility(FPendingFieldObjects.Objects[idx]);
2273 FPendingFieldObjects.Delete(idx);
2274 end;
2275 end;
2276
2277 procedure RegisterComponent;
2278 begin
2279 compKey := GetCompKey(component);
2280 if FComponentRegistry.IndexOf(compkey) < 0 then
2281 begin
2282 CreateHelper;
2283 FComponentRegistry.AddObject(compKey, Helper);
2284 if HasHandle(Component, HandleKey) then
2285 begin
2286 Helper.HandleKey := HandleKey;
2287 FHandlesXREF.AddObject(HandleKey, Helper);
2288 RegisterMSAA(Component);
2289 end
2290 else
2291 begin
2292 FHandlesPending.AddObject(compKey, Helper);
2293 if not FPendingRecheckTimer.Enabled then
2294 FPendingRecheckTimer.Enabled := TRUE;
2295 end;
2296 end;
2297 end;
2298
2299begin
2300 if FDestroying or (not assigned(Component)) then exit;
2301 RegisterComponent;
2302end;
2303
2304procedure TVAGlobalComponentRegistry.TimerEvent(Sender: TObject);
2305var
2306 idx: integer;
2307 Helper: TComponentHelper;
2308 handleKey: string;
2309
2310 function SkipCheck: boolean;
2311 begin
2312 Result := FDestroying or FUnregisteringComponent;
2313 end;
2314
2315begin
2316 if SkipCheck or FCheckingPendingList then exit;
2317 FCheckingPendingList := TRUE;
2318 try
2319 idx := FHandlesPending.Count-1;
2320 while (idx >= 0) and (not SkipCheck) do
2321 begin
2322 Helper := TComponentHelper(FHandlesPending.Objects[idx]);
2323 if HasHandle(Helper.Component, handleKey) then
2324 begin
2325 Helper.HandleKey := handleKey;
2326 FHandlesXREF.AddObject(handleKey, Helper);
2327 FHandlesPending.Delete(idx);
2328 RegisterMSAA(Helper.Component);
2329 end;
2330 dec(idx);
2331 end;
2332 if FHandlesPending.Count = 0 then
2333 FPendingRecheckTimer.Enabled := FALSE;
2334 finally
2335 FCheckingPendingList := FALSE;
2336 end;
2337end;
2338
2339procedure TVAGlobalComponentRegistry.UnregisterComponent(
2340 component: TWinControl);
2341var
2342 idx: integer;
2343 compKey, handleKey: string;
2344 Helper: TComponentHelper;
2345begin
2346 if FDestroying or (not assigned(component)) then exit;
2347 FUnregisteringComponent := TRUE;
2348 try
2349 compKey := GetCompKey(Component);
2350 idx := FComponentRegistry.IndexOf(compkey);
2351 if idx >= 0 then
2352 begin
2353 Helper := TComponentHelper(FComponentRegistry.Objects[idx]);
2354 handleKey := Helper.HandleKey;
2355 FComponentRegistry.Delete(idx);
2356 idx := FHandlesXREF.IndexOf(handleKey);
2357 if idx >= 0 then
2358 FHandlesXREF.Delete(idx);
2359 idx := FHandlesPending.IndexOf(compKey);
2360 if idx >= 0 then
2361 FHandlesPending.Delete(idx);
2362 Helper.Free;
2363 if assigned(Component) then
2364 UnregisterMSAA(Component);
2365 end;
2366 finally
2367 FUnregisteringComponent := FALSE;
2368 end;
2369end;
2370
2371
2372procedure TVAGlobalComponentRegistry.UnregisterMSAA(Component: TWinControl);
2373var
2374 Data: TMSAAData;
2375begin
2376 if Component.InheritsFrom(TWinControl) then
2377 begin
2378 Data := FindMSAAQueryData(TWinControlClass(Component.ClassType));
2379 if assigned(Data) then
2380 begin
2381 if assigned(Data.Proc) then
2382 UnregisterMSAAComponentQueryProc(Component, Data.Proc)
2383 else
2384 UnregisterMSAAComponentListQueryProc(Component, Data.ListProc);
2385 end;
2386 end;
2387end;
2388
2389procedure TVAGlobalComponentRegistry.UpdateHandles(WindowHandle: HWnd; var HandlesModified: boolean);
2390var
2391 Handle: Hwnd;
2392 TimerRunning: boolean;
2393 HandleIndex: integer;
2394
2395 procedure UpdateHandle(index: integer);
2396 var
2397 Helper: TComponentHelper;
2398 StatedHandle, TrueHandle: HWnd;
2399 key : string;
2400 idx: integer;
2401
2402 begin
2403 StatedHandle := FastHexToInt(FHandlesXREF[index]);
2404 Helper := TComponentHelper(FHandlesXREF.Objects[index]);
2405 if assigned(Helper) and assigned(Helper.Component) then
2406 begin
2407 TrueHandle := GetComponentHandle(Helper.Component);
2408 if TrueHandle <> 0 then
2409 begin
2410 if StatedHandle <> TrueHandle then
2411 begin
2412 key := FastIntToHex(TrueHandle);
2413 Helper.HandleKey := key;
2414 HandlesModified := TRUE;
2415 if FHandlesXREF.Sorted then
2416 begin
2417 FHandlesXREF.Delete(index);
2418 FHandlesXREF.AddObject(key, Helper);
2419 end
2420 else
2421 FHandlesXREF[index] := key;
2422 end;
2423 end
2424 else
2425 begin
2426 Helper.HandleKey := '';
2427 FHandlesPending.AddObject(GetCompKey(Helper.component), Helper);
2428 FHandlesXREF.Delete(index);
2429 TimerRunning := TRUE;
2430 end;
2431 end
2432 else
2433 begin
2434 FHandlesXREF.Delete(index);
2435 if assigned(Helper) then
2436 begin
2437 key := GetCompKey(Helper.component);
2438 idx := FComponentRegistry.IndexOf(key);
2439 if idx >= 0 then
2440 FComponentRegistry.delete(idx);
2441 Helper.Free;
2442 end;
2443 end;
2444 end;
2445
2446 function FindRootHandle(WindowHandle: HWnd; var idx: integer): Hwnd;
2447 var
2448 done: boolean;
2449 key: string;
2450
2451 begin
2452 Result := WindowHandle;
2453 done := FALSE;
2454 repeat
2455 key := FastIntToHex(Result);
2456 idx := FHandlesXREF.IndexOf(key);
2457 if idx < 0 then
2458 begin
2459 Result := Windows.GetAncestor(Result, GA_PARENT);
2460 if Result = 0 then
2461 done := TRUE;
2462 end
2463 else
2464 done := TRUE;
2465 until done;
2466 end;
2467
2468 procedure UpdateAllHandles;
2469 var
2470 i: integer;
2471 begin
2472 FHandlesXREF.Sorted := FALSE;
2473 try
2474 for I := FHandlesXREF.Count - 1 downto 0 do
2475 begin
2476 UpdateHandle(i);
2477 end;
2478 finally
2479 FHandlesXREF.Sorted := TRUE;
2480 end;
2481 end;
2482
2483 procedure UpdateChildrenHandles(idx: integer);
2484 var
2485 i, objIdx, hexidx: integer;
2486 Helper, child: TComponentHelper;
2487 objKey, key: string;
2488 ctrl: TControl;
2489 begin
2490 Helper := TComponentHelper(FHandlesXREF.Objects[idx]);
2491 if assigned(Helper) then
2492 begin
2493 if assigned(Helper.ComplexManager) then
2494 Helper.ComplexManager.Refresh(Helper.Component, Helper.Manager);
2495 for i := 0 to Helper.component.ControlCount-1 do
2496 begin
2497 ctrl := Helper.component.Controls[i];
2498 if assigned(ctrl) and (ctrl is TWinControl) then
2499 begin
2500 objKey := GetCompKey(TWinControl(ctrl));
2501 objIdx := FComponentRegistry.IndexOf(objKey);
2502 if objidx >= 0 then
2503 begin
2504 child := TComponentHelper(FComponentRegistry.Objects[objidx]);
2505 if assigned(child) then
2506 begin
2507 key := child.HandleKey;
2508 hexidx := FHandlesXREF.IndexOf(key);
2509 if hexidx >= 0 then
2510 begin
2511 UpdateHandle(hexidx);
2512 if key <> child.HandleKey then
2513 begin
2514 hexidx := FHandlesXREF.IndexOf(child.HandleKey);
2515 if hexidx >= 0 then
2516 begin
2517 UpdateChildrenHandles(hexidx);
2518 end;
2519 end;
2520 end;
2521 end;
2522 end
2523 end;
2524 end;
2525 end;
2526 end;
2527
2528begin
2529 TimerRunning := FPendingRecheckTimer.Enabled;
2530 FPendingRecheckTimer.Enabled := FALSE;
2531 HandlesModified := FALSE;
2532 try
2533 Handle := FindRootHandle(WindowHandle, HandleIndex);
2534 if Handle = 0 then
2535 UpdateAllHandles
2536 else
2537 UpdateChildrenHandles(HandleIndex);
2538 finally
2539 FPendingRecheckTimer.Enabled := TimerRunning;
2540 end;
2541end;
2542
2543{ TVA508ComponentManager }
2544
2545constructor TVA508ComponentManager.Create(ManagedTypes: TManagedTypes);
2546begin
2547 FManagedTypes := ManagedTypes;
2548end;
2549
2550function TVA508ComponentManager.GetCaption(Component: TWinControl): string;
2551begin
2552 Result := '';
2553end;
2554
2555function TVA508ComponentManager.GetComponentName(
2556 Component: TWinControl): string;
2557begin
2558 Result := '';
2559end;
2560
2561function TVA508ComponentManager.GetData(Component: TWinControl; Value: string): string;
2562begin
2563 Result := '';
2564end;
2565
2566function TVA508ComponentManager.GetInstructions(Component: TWinControl): string;
2567begin
2568 Result := '';
2569end;
2570
2571function TVA508ComponentManager.GetItem(Component: TWinControl): TObject;
2572begin
2573 Result := nil;
2574end;
2575
2576function TVA508ComponentManager.GetItemInstructions(
2577 Component: TWinControl): string;
2578begin
2579 Result := '';
2580end;
2581
2582function TVA508ComponentManager.GetState(Component: TWinControl): string;
2583begin
2584 Result := '';
2585end;
2586
2587function TVA508ComponentManager.GetValue(Component: TWinControl): string;
2588begin
2589 Result := '';
2590end;
2591
2592function TVA508ComponentManager.ManageCaption(Component: TWinControl): boolean;
2593begin
2594 Result := mtCaption in FManagedTypes;
2595end;
2596
2597function TVA508ComponentManager.ManageComponentName(
2598 Component: TWinControl): boolean;
2599begin
2600 Result := mtComponentName in FManagedTypes;
2601end;
2602
2603function TVA508ComponentManager.ManageData(Component: TWinControl): boolean;
2604begin
2605 Result := mtData in FManagedTypes;
2606end;
2607
2608function TVA508ComponentManager.ManageInstructions(
2609 Component: TWinControl): boolean;
2610begin
2611 Result := mtInstructions in FManagedTypes;
2612end;
2613
2614function TVA508ComponentManager.ManageItemInstructions(
2615 Component: TWinControl): boolean;
2616begin
2617 Result := mtItemInstructions in FManagedTypes;
2618end;
2619
2620function TVA508ComponentManager.ManageState(Component: TWinControl): boolean;
2621begin
2622 Result := mtState in FManagedTypes;
2623end;
2624
2625function TVA508ComponentManager.ManageValue(Component: TWinControl): boolean;
2626begin
2627 Result := mtValue in FManagedTypes;
2628end;
2629
2630function TVA508ComponentManager.MonitorForItemChange(
2631 Component: TWinControl): boolean;
2632begin
2633 Result := mtItemChange in FManagedTypes;
2634end;
2635
2636function TVA508ComponentManager.MonitorForStateChange(
2637 Component: TWinControl): boolean;
2638begin
2639 Result := mtStateChange in FManagedTypes;
2640end;
2641
2642function TVA508ComponentManager.Redirect(Component: TWinControl;
2643 var ManagedType: TManagedType): TWinControl;
2644begin
2645 Result := nil;
2646 ManagedType := mtNone;
2647end;
2648
2649function TVA508ComponentManager.RedirectsComponent(Component: TWinControl): boolean;
2650begin
2651 Result := mtComponentRedirect in FManagedTypes;
2652end;
2653
2654{ TVA508ManagedComponentClass }
2655
2656constructor TVA508ManagedComponentClass.Create(AClassType: TWinControlClass;
2657 ManageTypes: TManagedTypes; AManageDescendentClasses: boolean = FALSE);
2658begin
2659 FClassType := AClassType;
2660 FManageDescendentClasses := AManageDescendentClasses;
2661 inherited Create(ManageTypes);
2662end;
2663
2664{ TVA508SilentComponent }
2665
2666function TVA508SilentComponent.GetComponentName(Component: TWinControl): string;
2667begin
2668 Result := ComponentManagerSilentText;
2669end;
2670
2671function TVA508SilentComponent.GetInstructions(Component: TWinControl): string;
2672begin
2673 Result := ComponentManagerSilentText;
2674end;
2675
2676function TVA508SilentComponent.GetState(Component: TWinControl): string;
2677begin
2678 Result := ComponentManagerSilentText;
2679end;
2680
2681function TVA508SilentComponent.GetValue(Component: TWinControl): string;
2682begin
2683 Result := ComponentManagerSilentText;
2684end;
2685
2686{ TVA508AccessibilityEvents }
2687
2688constructor TVA508ComponentAccessibility.Create(AOwner: TComponent);
2689begin
2690 inherited Create(AOwner);
2691 VA508ComponentCreationCheck(Self, AOwner, FALSE, TRUE);
2692 CreateGlobalRegistry;
2693end;
2694
2695procedure TVA508ComponentAccessibility.SetComponent(const Value: TWinControl);
2696var
2697 i: integer;
2698 Comp: TComponent;
2699begin
2700 if FComponent <> Value then
2701 begin
2702 if assigned(Value) then
2703 begin
2704 for i := 0 to Owner.ComponentCount-1 do
2705 begin
2706 Comp := Owner.Components[i];
2707 if (Comp is TVA508ComponentAccessibility) and (Comp <> Self) then
2708 begin
2709 if TVA508ComponentAccessibility(Comp).Component = Value then
2710 raise TVA508Exception.Create(Value.Name + ' is already assigned to another ' +
2711 TVA508ComponentAccessibility.ClassName + ' component');
2712 end;
2713 end;
2714 if assigned(GlobalRegistry) then
2715 begin
2716 if assigned(FComponent) then
2717 GlobalRegistry.RegisterFieldObject(FComponent, Self, FALSE);
2718 GlobalRegistry.RegisterFieldObject(Value, Self, TRUE);
2719 end;
2720 FComponent := Value;
2721 end
2722 else
2723 begin
2724 if assigned(FComponent) and assigned(GlobalRegistry) then
2725 GlobalRegistry.RegisterFieldObject(FComponent, Self, FALSE);
2726 FComponent := nil;
2727 end;
2728 end;
2729end;
2730
2731{ TComponentHelper }
2732
2733procedure TComponentHelper.InitializeComponentManager;
2734
2735var
2736 ClsManager: TVA508ManagedComponentClass;
2737 CompManager: TVA508ComponentManager;
2738 data: string;
2739
2740 procedure InitializeComponentHelper;
2741 begin
2742 if assigned(FComponentManager) and FComponentManager.RedirectsComponent(FComponent) then
2743 begin
2744 FRedirectedComponent := FComponentManager.Redirect(FComponent, FRedirectedHelperType);
2745 if FRedirectedComponent.Visible then
2746 begin
2747 FRedirectedHelper := GlobalRegistry.GetComponentHelper(FRedirectedComponent.Handle);
2748 if assigned(FRedirectedHelper) then
2749 FRedirectedHelper.InitializeComponentManager
2750 else
2751 ClearRedirect;
2752
2753 data := FRedirectedComponent.ClassName + ' / ';
2754 if assigned(FRedirectedHelper.ComponentManager) then
2755 data := data + FRedirectedHelper.ComponentManager.ClassName
2756 else data := data +' no manager';
2757 end
2758 else
2759 ClearRedirect;
2760 end
2761 else
2762 ClearRedirect;
2763 end;
2764
2765begin
2766 ClsManager := ManagedClassData;
2767 CompManager := Manager.ComponentManager[Component];
2768 if assigned(ClsManager) or assigned(CompManager) then
2769 begin
2770 if assigned(CompManager) then
2771 FComponentManager := CompManager
2772 else
2773 FComponentManager := ClsManager;
2774 end
2775 else
2776 FComponentManager := nil;
2777 InitializeComponentHelper;
2778end;
2779
2780procedure TComponentHelper.ClearRedirect;
2781begin
2782 FRedirectedHelper := nil;
2783 FRedirectedHelperType := mtNone;
2784 FRedirectedComponent := nil;
2785end;
2786
2787constructor TComponentHelper.Create;
2788begin
2789 ClearRedirect;
2790end;
2791
2792destructor TComponentHelper.Destroy;
2793begin
2794 if Assigned(GlobalRegistry) and (GlobalRegistry.FCurrentHelper = Self) then
2795 GlobalRegistry.FCurrentHelper := nil;
2796 if Assigned(GlobalRegistry) and assigned(GlobalRegistry.FCurrentHelper) and
2797 (GlobalRegistry.FCurrentHelper.FRedirectedHelper = Self) then
2798 GlobalRegistry.FCurrentHelper := nil;
2799 inherited;
2800end;
2801
2802function TComponentHelper.GetCaption(var DataResult: Integer): string;
2803begin
2804 if Redirect(mtCaption) then
2805 Result := FRedirectedHelper.GetCaption(DataResult)
2806 else
2807 begin
2808 Result := Manager.ScreenReaderInquiry(FComponent);
2809 if Result = '' then
2810 begin
2811 if assigned(FFieldObject) and (FFieldObject.FCaption <> '') then
2812 Result := FFieldObject.FCaption
2813 else
2814 if assigned(FComponentManager) and FComponentManager.ManageCaption(FComponent) then
2815 Result := FComponentManager.GetCaption(FComponent)
2816 end;
2817 if assigned(FieldObject) and assigned(FieldObject.OnCaptionQuery) then
2818 FieldObject.OnCaptionQuery(FieldObject, Result);
2819 if Result <> '' then
2820 DataResult := DataResult OR DATA_CAPTION;
2821 end;
2822end;
2823
2824function TComponentHelper.GetComponentName(var DataResult: Integer): string;
2825begin
2826 if Redirect(mtComponentName) then
2827 Result := FRedirectedHelper.GetComponentName(DataResult)
2828 else
2829 begin
2830 Result := '';
2831 if assigned(FFieldObject) and (FFieldObject.FComponentName <> '') then
2832 Result := FFieldObject.FComponentName
2833 else if assigned(FComponentManager) and FComponentManager.ManageComponentName(FComponent) then
2834 Result := FComponentManager.GetComponentName(FComponent);
2835 if assigned(FFieldObject) and assigned(FFieldObject.FOnComponentNameQuery) then
2836 FFieldObject.FOnComponentNameQuery(FFieldObject, Result);
2837 if Result <> '' then
2838 DataResult := DataResult OR DATA_CONTROL_TYPE;
2839 end;
2840end;
2841
2842function TComponentHelper.GetData(var DataResult: Integer; Value: string): string;
2843begin
2844 if Redirect(mtData) then
2845 Result := FRedirectedHelper.GetData(DataResult, Value)
2846 else
2847 begin
2848 Result := '';
2849 if assigned(FComponentManager) and FComponentManager.ManageData(FComponent) then
2850 begin
2851 Result := FComponentManager.GetData(FComponent, Value);
2852 if Result <> '' then
2853 DataResult := DataResult OR DATA_DATA;
2854 end;
2855 end;
2856end;
2857
2858function TComponentHelper.GetInstructions(var DataResult: Integer): string;
2859begin
2860 if Redirect(mtInstructions) then
2861 Result := FRedirectedHelper.GetInstructions(DataResult)
2862 else
2863 begin
2864 Result := '';
2865 if assigned(FFieldObject) and (FFieldObject.FInstructions <> '') then
2866 Result := FFieldObject.FInstructions
2867 else if assigned(FComponentManager) and FComponentManager.ManageInstructions(FComponent) then
2868 Result := FComponentManager.GetInstructions(FComponent);
2869 if assigned(FFieldObject) and assigned(FFieldObject.FOnInstructionsQuery) then
2870 FFieldObject.FOnInstructionsQuery(FFieldObject, Result);
2871 if Result <> '' then
2872 DataResult := DataResult OR DATA_INSTRUCTIONS;
2873 end;
2874end;
2875
2876function TComponentHelper.GetItem: TObject;
2877begin
2878 if Redirect(mtItemChange) then
2879 FRedirectedHelper.GetItem
2880 else
2881 begin
2882 Result := nil;
2883 if assigned(FComponentManager) and FComponentManager.MonitorForItemChange(FComponent) then
2884 Result := FComponentManager.GetItem(FComponent);
2885 if assigned(FFieldObject) and assigned(FFieldObject.FOnItemQuery) then
2886 FFieldObject.FOnItemQuery(FFieldObject, Result);
2887 end;
2888end;
2889
2890function TComponentHelper.GetItemInstructions(var DataResult: Integer): string;
2891begin
2892 if Redirect(mtItemInstructions) then
2893 Result := FRedirectedHelper.GetItemInstructions(DataResult)
2894 else
2895 begin
2896 Result := '';
2897 if assigned(FFieldObject) and (FFieldObject.FItemInstructions <> '') then
2898 Result := FFieldObject.FItemInstructions
2899 else if assigned(FComponentManager) and FComponentManager.ManageItemInstructions(FComponent) then
2900 Result := FComponentManager.GetItemInstructions(FComponent);
2901 if assigned(FFieldObject) and assigned(FFieldObject.FOnItemInstructionsQuery) then
2902 FFieldObject.FOnItemInstructionsQuery(FFieldObject, Result);
2903 if Result <> '' then
2904 DataResult := DataResult OR DATA_ITEM_INSTRUCTIONS;
2905 end;
2906end;
2907
2908function TComponentHelper.GetState(var DataResult: Integer): string;
2909begin
2910 Result := '';
2911 try
2912 if Redirect(mtState) then
2913 Result := FRedirectedHelper.GetState(DataResult)
2914 else
2915 begin
2916 if assigned(FComponentManager) and FComponentManager.MonitorForStateChange(FComponent) and
2917 FComponentManager.ManageState(FComponent) then
2918 Result := FComponentManager.GetState(FComponent);
2919 if assigned(FFieldObject) and assigned(FFieldObject.FOnStateQuery) then
2920 FFieldObject.FOnStateQuery(FFieldObject, Result);
2921 if Result <> '' then
2922 DataResult := DataResult OR DATA_STATE;
2923 end;
2924 except
2925 // access violations occur here during reminder dialogs - could never figure out why
2926 // Self = nil when looking at FFieldObject, but checks before that line showed Self <> nil
2927 end;
2928end;
2929
2930function TComponentHelper.GetValue(var DataResult: Integer): string;
2931begin
2932 if Redirect(mtValue) then
2933 begin
2934 Result := FRedirectedHelper.GetValue(DataResult);
2935 end
2936 else
2937 begin
2938 Result := '';
2939 if assigned(FComponentManager) and FComponentManager.ManageValue(FComponent) then
2940 Result := FComponentManager.GetValue(FComponent);
2941 if assigned(FFieldObject) and assigned(FFieldObject.FOnValueQuery) then
2942 FFieldObject.FOnValueQuery(FFieldObject, Result);
2943 if Result <> '' then
2944 DataResult := DataResult OR DATA_VALUE;
2945 end;
2946end;
2947
2948function TComponentHelper.ManageComponentName: boolean;
2949begin
2950 if Redirect(mtComponentName) then
2951 Result := FRedirectedHelper.ManageComponentName
2952 else
2953 begin
2954 if assigned(FFieldObject) and
2955 (assigned(FFieldObject.FOnComponentNameQuery) or (FFieldObject.FComponentName <> '')) then
2956 Result := TRUE
2957 else
2958 begin
2959 if assigned(FComponentManager) then
2960 Result := FComponentManager.ManageComponentName(FComponent)
2961 else
2962 Result := FALSE;
2963 end;
2964 end;
2965end;
2966
2967function TComponentHelper.ManageData: boolean;
2968begin
2969 if Redirect(mtData) then
2970 Result := FRedirectedHelper.ManageData
2971 else
2972 begin
2973 if assigned(FComponentManager) then
2974 Result := FComponentManager.ManageData(FComponent)
2975 else
2976 Result := FALSE;
2977 end;
2978end;
2979
2980function TComponentHelper.ManageInstructions: boolean;
2981begin
2982 if Redirect(mtInstructions) then
2983 Result := FRedirectedHelper.ManageInstructions
2984 else
2985 begin
2986 if assigned(FFieldObject) and
2987 (assigned(FFieldObject.FOnInstructionsQuery) or (FFieldObject.FInstructions <> '')) then
2988 Result := TRUE
2989 else
2990 begin
2991 if assigned(FComponentManager) then
2992 Result := FComponentManager.ManageInstructions(FComponent)
2993 else
2994 Result := FALSE;
2995 end;
2996 end;
2997end;
2998
2999function TComponentHelper.ManageItemInstructions: boolean;
3000begin
3001 if Redirect(mtItemInstructions) then
3002 Result := FRedirectedHelper.ManageItemInstructions
3003 else
3004 begin
3005 if assigned(FFieldObject) and
3006 (assigned(FFieldObject.FOnItemInstructionsQuery) or (FFieldObject.FItemInstructions <> '')) then
3007 Result := TRUE
3008 else
3009 begin
3010 if assigned(FComponentManager) then
3011 Result := FComponentManager.ManageItemInstructions(FComponent)
3012 else
3013 Result := FALSE;
3014 end;
3015 end;
3016end;
3017
3018function TComponentHelper.ManageValue: boolean;
3019begin
3020 if Redirect(mtValue) then
3021 begin
3022 Result := FRedirectedHelper.ManageValue;
3023 end
3024 else
3025 begin
3026 if assigned(FFieldObject) and assigned(FFieldObject.FOnValueQuery) then
3027 Result := TRUE
3028 else
3029 begin
3030 if assigned(FComponentManager) then
3031 Result := FComponentManager.ManageValue(FComponent)
3032 else
3033 Result := FALSE;
3034 end;
3035 end;
3036end;
3037
3038function TComponentHelper.ManageCaption: boolean;
3039begin
3040 if Redirect(mtCaption) then
3041 Result := FRedirectedHelper.ManageCaption
3042 else
3043 begin
3044 if assigned(FFieldObject) and
3045 (assigned(FFieldObject.OnCaptionQuery) or (FFieldObject.FCaption <> '')) then
3046 Result := TRUE
3047 else
3048 begin
3049 if assigned(FComponentManager) then
3050 Result := FComponentManager.ManageCaption(FComponent)
3051 else
3052 Result := FALSE;
3053 end;
3054 end;
3055end;
3056
3057function TComponentHelper.MonitorForItemChange: boolean;
3058begin
3059 if Redirect(mtItemChange) then
3060 Result := FRedirectedHelper.MonitorForItemChange
3061 else
3062 begin
3063 if assigned(FFieldObject) and assigned(FFieldObject.FOnItemQuery) then
3064 Result := TRUE
3065 else
3066 begin
3067 if assigned(FComponentManager) then
3068 Result := FComponentManager.MonitorForItemChange(FComponent)
3069 else
3070 Result := FALSE;
3071 end;
3072 end;
3073end;
3074
3075function TComponentHelper.MonitorForStateChange: boolean;
3076begin
3077 if Redirect(mtStateChange) then
3078 Result := FRedirectedHelper.MonitorForStateChange
3079 else
3080 begin
3081 if assigned(FFieldObject) and assigned(FFieldObject.OnStateQuery) then
3082 Result := TRUE
3083 else
3084 begin
3085 if assigned(FComponentManager) then
3086 Result := FComponentManager.MonitorForStateChange(FComponent) and
3087 FComponentManager.ManageState(FComponent)
3088 else
3089 Result := FALSE;
3090 end;
3091 end;
3092end;
3093
3094function TComponentHelper.Redirect(RedirectType: TManagedType): boolean;
3095begin
3096 Result := FALSE;
3097 if assigned(FRedirectedHelper) and assigned(FRedirectedComponent) and
3098 (FRedirectedHelperType = RedirectType) then
3099 Result := TRUE;
3100end;
3101
3102function TComponentHelper.StandardComponent: boolean;
3103begin
3104 Result := ((not assigned(FComponentManager)) and (not assigned(FFieldObject)));
3105end;
3106
3107{ TVA508StaticText }
3108type
3109 TFriendLabel = class(TLabel);
3110
3111procedure TVA508StaticText.CMFontChanged(var Message: TMessage);
3112begin
3113 inherited;
3114 UpdateSize;
3115end;
3116
3117procedure TVA508StaticText.CMTextChanged(var Message: TMessage);
3118begin
3119 inherited;
3120 UpdateSize;
3121end;
3122
3123constructor TVA508StaticText.Create;
3124begin
3125 inherited;
3126 FLabel := TLabel.Create(Self);
3127 FLabel.Parent := Self;
3128 FLabel.Align := alClient;
3129 ControlStyle := ControlStyle - [csAcceptsControls];
3130 FInitTabStop := (not TabStop);
3131end;
3132
3133procedure TVA508StaticText.DeleteChain(FromLabel, ToLabel: TVA508ChainedLabel);
3134var
3135 next, lbl: TVA508ChainedLabel;
3136 prev: TControl;
3137begin
3138 if FDeletingChain then exit;
3139 if FromLabel = ToLabel then exit;
3140 FDeletingChain := TRUE;
3141 try
3142 next := NextLabel;
3143 while assigned(next) and (next <> FromLabel) do
3144 next := next.NextLabel;
3145 if assigned(next) then
3146 begin
3147 prev := next.FPreviousLabel;
3148 repeat
3149 lbl := next;
3150 next := next.NextLabel;
3151 lbl.Free;
3152 until (not assigned(next)) or (next = ToLabel);
3153 if assigned(ToLabel) then
3154 ToLabel.FPreviousLabel := prev;
3155 end;
3156 finally
3157 FDeletingChain := FALSE;
3158 end;
3159end;
3160
3161destructor TVA508StaticText.Destroy;
3162begin
3163 if assigned(FNextLabel) then
3164 DeleteChain(FNextLabel, nil);
3165 inherited;
3166end;
3167
3168procedure TVA508StaticText.DoEnter;
3169begin
3170 inherited DoEnter;
3171 InvalidateAll;
3172 if Assigned(FOnEnter) then
3173 FOnEnter(Self);
3174end;
3175
3176procedure TVA508StaticText.DoExit;
3177begin
3178 inherited DoExit;
3179 InvalidateAll;
3180 if Assigned(FOnExit) then
3181 FOnExit(Self);
3182end;
3183
3184function TVA508StaticText.GetAlignment: TAlignment;
3185begin
3186 Result := FLabel.Alignment;
3187end;
3188
3189function TVA508StaticText.GetLabelCaption: string;
3190begin
3191 Result := FLabel.Caption;
3192end;
3193
3194function TVA508StaticText.GetRootName: string;
3195begin
3196 result := inherited Name;
3197end;
3198
3199function TVA508StaticText.GetShowAccelChar: boolean;
3200begin
3201 Result := FLabel.ShowAccelChar;
3202end;
3203
3204procedure TVA508StaticText.InvalidateAll;
3205var
3206 next: TVA508ChainedLabel;
3207begin
3208 invalidate;
3209 next := FNextLabel;
3210 while assigned(next) do
3211 begin
3212 next.Invalidate;
3213 next := next.NextLabel;
3214 end;
3215end;
3216
3217procedure TVA508StaticText.Notification(AComponent: TComponent; Operation: TOperation);
3218begin
3219 inherited;
3220 if csDestroying in ComponentState then exit;
3221 if (Operation = opRemove) and (AComponent = FNextLabel) and (not FDeletingChain) then
3222 SetNextLabel(nil);
3223end;
3224
3225procedure TVA508StaticText.Paint;
3226var
3227 x1, x2, y1, y2: integer;
3228
3229 procedure Init;
3230 begin
3231 Canvas.Font := Self.Font;
3232 with Canvas do
3233 begin
3234 Pen.Width := 1;
3235 Brush.Color := clNone;
3236 Brush.Style := bsClear;
3237 end;
3238 end;
3239
3240// procedure DrawText;
3241// begin
3242// with Canvas do
3243// begin
3244// Pen.color := Self.Font.Color;
3245// Pen.Style := psSolid;
3246// TextOut(1, 0, Caption);
3247// end;
3248// end;
3249
3250 procedure InitDrawBorder;
3251 var
3252 r: TRect;
3253 begin
3254 with Canvas do
3255 begin
3256 if Focused then
3257 begin
3258 Pen.Style := psDot;
3259 Pen.Color := Self.Font.Color;
3260 end
3261 else
3262 begin
3263 Pen.Style := psSolid;
3264 pen.Color := Self.Color;
3265 end;
3266 end;
3267 R := ClientRect;
3268 R.Bottom := R.Bottom - 1;
3269 R.Right := R.Right - 1;
3270 x1 := R.Left;
3271 y1 := R.Top;
3272 x2 := R.Right;
3273 y2 := R.Bottom;
3274 end;
3275
3276 procedure DrawTop;
3277 begin
3278 With Canvas do
3279 begin
3280 MoveTo(x1, y2);
3281 LineTo(x1, y1);
3282 LineTo(x2, y1);
3283 LineTo(x2, y2);
3284 end;
3285 end;
3286
3287 procedure DrawBottom;
3288 var
3289 bx1,bx2, max: integer;
3290 r: TRect;
3291 r2: TRect;
3292 begin
3293 with Canvas do
3294 begin
3295 if assigned(FNextLabel) then
3296 begin
3297 r := BoundsRect;
3298 r2 := FNextLabel.BoundsRect;
3299 if r.top < r2.top then
3300 begin
3301 bx1 := r2.Left - r.Left;
3302 if (bx1 > 0) then
3303 begin
3304 if bx1 > x2 then
3305 max := x2
3306 else
3307 max := bx1;
3308 moveto(x1,y2);
3309 lineto(max,y2);
3310 end;
3311 bx2 := x2 - (r.Right - r2.Right);
3312 if bx2 < x2 then
3313 begin
3314 if bx2 < x1 then
3315 max := x1
3316 else
3317 max := bx2;
3318 moveto(x2,y2);
3319 lineto(max,y2);
3320 end;
3321 end;
3322 end
3323 else
3324 LineTo(x1, y2);
3325 end;
3326 end;
3327
3328begin
3329 Init;
3330// if Focused then
3331// DrawText;
3332 InitDrawBorder;
3333 DrawTop;
3334 DrawBottom;
3335// if not Focused then
3336// DrawText;
3337end;
3338
3339procedure TVA508StaticText.SetAlignment(const Value: TAlignment);
3340begin
3341 FLabel.Alignment := Value;
3342end;
3343
3344procedure TVA508StaticText.SetLabelCaption(const Value: string);
3345begin
3346 if FLabel.Caption <> Value then
3347 begin
3348 FLabel.Caption := Value;
3349 UpdateSize;
3350 end;
3351end;
3352
3353procedure TVA508StaticText.SetRootName(const Value: string);
3354begin
3355 if inherited Name <> Value then
3356 begin
3357 if FLabel.Caption = inherited Name then
3358 FLabel.Caption := Value;
3359 inherited Name := Value;
3360 inherited Caption := '';
3361 end;
3362end;
3363
3364procedure TVA508StaticText.SetNextLabel(const Value: TVA508ChainedLabel);
3365begin
3366 if FNextLabel <> Value then
3367 begin
3368 if assigned(FNextLabel) then
3369 DeleteChain(FNextLabel, Value);
3370 FNextLabel := Value;
3371 if assigned(FNextLabel) then
3372 begin
3373 FNextLabel.FStaticLabelParent := Self;
3374 FNextLabel.FPreviousLabel := Self;
3375 end;
3376 invalidate;
3377 end;
3378end;
3379
3380procedure TVA508StaticText.SetParent(AParent: TWinControl);
3381begin
3382 inherited SetParent(AParent);
3383 if assigned(AParent) then
3384 begin
3385 if FInitTabStop then
3386 begin
3387 if csDesigning in ComponentState then
3388 TabStop := FALSE
3389 else
3390 TabStop := ScreenReaderActive;
3391 FInitTabStop := FALSE;
3392 end;
3393 Perform(CM_FONTCHANGED, 0, 0);
3394 end;
3395end;
3396
3397procedure TVA508StaticText.SetShowAccelChar(const Value: boolean);
3398begin
3399 FLabel.ShowAccelChar := Value;
3400end;
3401
3402procedure TVA508StaticText.UpdateSize;
3403begin
3404 FLabel.Align := alNone;
3405 try
3406 TFriendLabel(FLabel).AdjustBounds;
3407 Height := FLabel.Height + 2;
3408 Width := FLabel.Width + 2;
3409 finally
3410 FLabel.Align := alClient;
3411 end;
3412end;
3413
3414{ TVA508ChainedLabel }
3415
3416procedure TVA508ChainedLabel.Notification(AComponent: TComponent;
3417 Operation: TOperation);
3418begin
3419 inherited;
3420 if not assigned(FStaticLabelParent) then exit;
3421 if csDestroying in ComponentState then exit;
3422 if (Operation = opRemove) and (AComponent = FNextLabel) and (not FStaticLabelParent.FDeletingChain) then
3423 SetNextLabel(nil);
3424end;
3425
3426procedure TVA508ChainedLabel.Paint;
3427var
3428 x1, x2, y1, y2: integer;
3429
3430 procedure Init;
3431 begin
3432 Canvas.Font := Self.Font;
3433 with Canvas do
3434 begin
3435 Pen.Width := 1;
3436 Brush.Color := clNone;
3437 Brush.Style := bsClear;
3438 end;
3439 end;
3440
3441 procedure DrawText;
3442 begin
3443 with Canvas do
3444 begin
3445 Pen.color := Self.Font.Color;
3446 Pen.Style := psSolid;
3447 TextOut(0, 0, Caption);
3448 end;
3449 end;
3450
3451 procedure InitDrawBorder;
3452 var
3453 r: TRect;
3454 begin
3455 with Canvas do
3456 begin
3457 if FStaticLabelParent.Focused then
3458 begin
3459 Pen.Style := psDot;
3460 Pen.Color := Self.Font.Color;
3461 end
3462 else
3463 begin
3464 if transparent then
3465 begin
3466 Pen.Style := psClear;
3467 Pen.Color := clNone;
3468 end
3469 else
3470 begin
3471 Pen.Style := psSolid;
3472 pen.Color := Self.Color;
3473 end;
3474 end;
3475 end;
3476 R := ClientRect;
3477 R.Bottom := R.Bottom - 1;
3478 R.Right := R.Right - 1;
3479 x1 := R.Left;
3480 y1 := R.Top;
3481 x2 := R.Right;
3482 y2 := R.Bottom;
3483 end;
3484
3485 procedure DrawPartials(x3, x4, y: integer);
3486 var
3487 max: integer;
3488 begin
3489 with Canvas do
3490 begin
3491 if (x3 > x1) then
3492 begin
3493 if x3 > x2 then
3494 max := x2
3495 else
3496 max := x3;
3497 moveto(x1,y);
3498 lineto(max,y);
3499 end;
3500 if x4 < x2 then
3501 begin
3502 if x4 < x1 then
3503 max := x1
3504 else
3505 max := x4;
3506 moveto(x2,y);
3507 lineto(max,y);
3508 end;
3509 end;
3510 end;
3511
3512 procedure DrawTop;
3513 var
3514 r, r2: TRect;
3515 tx1,tx2: integer;
3516 begin
3517 With Canvas do
3518 begin
3519 r2 := BoundsRect;
3520 r := FPreviousLabel.BoundsRect;
3521 if r.top < r2.top then
3522 begin
3523 tx1 := r.Left - r2.Left;
3524 tx2 := x2 - (r2.Right - r.Right);
3525 DrawPartials(tx1,tx2,y1);
3526 end
3527 else
3528 begin
3529 MoveTo(x1, y1);
3530 LineTo(x2, y1);
3531 end;
3532 end;
3533 end;
3534
3535 procedure DrawSides;
3536 begin
3537 With Canvas do
3538 begin
3539 MoveTo(x1,y1);
3540 LineTo(x1,y2);
3541 MoveTo(x2,y1);
3542 LineTo(x2,y2);
3543 end;
3544 end;
3545
3546 procedure DrawBottom;
3547 var
3548 r, r2: TRect;
3549 doBottom: boolean;
3550 bx1,bx2: integer;
3551 begin
3552 With Canvas do
3553 begin
3554 if assigned(FNextLabel) then
3555 begin
3556 r := BoundsRect;
3557 r2 := FNextLabel.BoundsRect;
3558 if r.top < r2.top then
3559 begin
3560 doBottom := FALSE;
3561 bx1 := r2.Left - r.Left;
3562 bx2 := x2 - (r.Right - r2.Right);
3563 DrawPartials(bx1,bx2,y2);
3564 end
3565 else
3566 doBottom := TRUE;
3567 end
3568 else
3569 doBottom := TRUE;
3570 if DoBottom then
3571 begin
3572 MoveTo(x1, y2);
3573 LineTo(x2, y2);
3574 end;
3575 end;
3576 end;
3577
3578begin
3579 Init;
3580 if FStaticLabelParent.Focused then
3581 DrawText;
3582 InitDrawBorder;
3583 DrawTop;
3584 DrawSides;
3585 DrawBottom;
3586 if not FStaticLabelParent.Focused then
3587 DrawText;
3588end;
3589
3590procedure TVA508ChainedLabel.SetNextLabel(const Value: TVA508ChainedLabel);
3591begin
3592 if not assigned(FStaticLabelParent) then exit;
3593 if FNextLabel <> Value then
3594 begin
3595 if assigned(FNextLabel) then
3596 FStaticLabelParent.DeleteChain(FNextLabel, Value);
3597 FNextLabel := Value;
3598 if assigned(FNextLabel) then
3599 begin
3600 FNextLabel.FStaticLabelParent := FStaticLabelParent;
3601 FNextLabel.FPreviousLabel := Self;
3602 end;
3603 invalidate;
3604 end;
3605end;
3606
3607{ TVA508ComplexComponentManager }
3608
3609type
3610 TComplexDataItem = class(TObject)
3611 private
3612 FList: TList;
3613 FComponent: TWinControl;
3614 FSubComponent: TWinControl;
3615 public
3616 constructor Create(Component, SubComponent: TWinControl);
3617 destructor Destroy; override;
3618 end;
3619
3620{ TComplexDataItem }
3621
3622constructor TComplexDataItem.Create(Component, SubComponent: TWinControl);
3623begin
3624 FComponent := Component;
3625 FSubComponent := SubComponent;
3626 if assigned(FSubComponent) then
3627 FList := nil
3628 else
3629 FList := TList.Create;
3630end;
3631
3632destructor TComplexDataItem.Destroy;
3633begin
3634 if assigned(FList) then
3635 FList.Free;
3636 inherited;
3637end;
3638
3639
3640procedure TVA508ComplexComponentManager.AddSubControl(ParentComponent, SubControl: TWinControl;
3641 AccessibilityManager: TVA508AccessibilityManager);
3642var
3643 list: TList;
3644 item : TComplexDataItem;
3645begin
3646 if (not assigned(ParentComponent)) or (not assigned(SubControl)) then exit;
3647 list := GetSubComponentList(ParentComponent);
3648 if list.IndexOf(SubControl) < 0 then
3649 begin
3650 list.Add(SubControl);
3651 if IndexOfSubComponentXRef(SubControl) < 0 then
3652 begin
3653 item := TComplexDataItem.Create(ParentComponent, SubControl);
3654 FSubComponentXRef.Add(item);
3655 SubControl.FreeNotification(FSubComponentNotifier);
3656 end;
3657 if assigned(AccessibilityManager) and assigned(GlobalRegistry) then
3658 GlobalRegistry.RegisterComponent(SubControl, AccessibilityManager);
3659 end;
3660end;
3661
3662procedure TVA508ComplexComponentManager.RemoveSubControl(ParentComponent, SubControl: TWinControl);
3663var
3664 list: TList;
3665 idx: integer;
3666begin
3667 if (not assigned(ParentComponent)) or (not assigned(SubControl)) then exit;
3668 list := GetSubComponentList(ParentComponent);
3669 idx := list.IndexOf(SubControl);
3670 if idx >= 0 then
3671 begin
3672 List.Delete(idx);
3673 idx := IndexOfSubComponentXRef(SubControl);
3674 if idx >= 0 then
3675 begin
3676 FSubComponentXRef.Delete(idx);
3677 SubControl.RemoveFreeNotification(FSubComponentNotifier);
3678 end;
3679 if assigned(GlobalRegistry) then
3680 GlobalRegistry.UnregisterComponent(SubControl);
3681 end;
3682end;
3683
3684procedure TVA508ComplexComponentManager.ClearSubControls(Component: TWinControl);
3685var
3686 list: TList;
3687 idx, i: integer;
3688 SubControl: TWinControl;
3689
3690begin
3691 if (not assigned(Component)) then exit;
3692 list := GetSubComponentList(Component);
3693 for i := 0 to list.Count - 1 do
3694 begin
3695 SubControl := TWinControl(list[i]);
3696 idx := IndexOfSubComponentXRef(SubControl);
3697 if idx >= 0 then
3698 begin
3699 FSubComponentXRef.Delete(idx);
3700 SubControl.RemoveFreeNotification(FSubComponentNotifier);
3701 end;
3702 if assigned(GlobalRegistry) then
3703 GlobalRegistry.UnregisterComponent(SubControl);
3704 end;
3705 list.Clear;
3706end;
3707
3708constructor TVA508ComplexComponentManager.Create(
3709 AComponentClass: TWinControlClass);
3710begin
3711 FComponentClass := AComponentClass;
3712 FComponentNotifier := TVANotificationEventComponent.NotifyCreate(nil, ComponentNotifyEvent);
3713 FSubComponentNotifier := TVANotificationEventComponent.NotifyCreate(nil, SubComponentNotifyEvent);
3714 FComponentList := TObjectList.Create;
3715 FSubComponentXRef := TObjectList.Create;
3716end;
3717
3718destructor TVA508ComplexComponentManager.Destroy;
3719begin
3720 FSubComponentXRef.Free;
3721 FComponentList.Free;
3722 FComponentNotifier.Free;
3723 FSubComponentNotifier.Free;
3724 inherited;
3725end;
3726
3727function TVA508ComplexComponentManager.GetSubComponentList(Component: TWinControl): TList;
3728var
3729 i: integer;
3730 item: TComplexDataItem;
3731begin
3732 i := IndexOfComponentItem(Component);
3733 if i < 0 then
3734 begin
3735 item := TComplexDataItem.Create(Component, nil);
3736 i := FComponentList.Add(item);
3737 Component.FreeNotification(FComponentNotifier);
3738 end;
3739 Result := TComplexDataItem(FComponentList[i]).FList;
3740end;
3741
3742function TVA508ComplexComponentManager.GetSubControl(Component: TWinControl;
3743 Index: integer): TWinControl;
3744begin
3745 if assigned(Component) then
3746 Result := TWinControl(GetSubComponentList(Component)[Index])
3747 else
3748 Result := nil;
3749end;
3750
3751function TVA508ComplexComponentManager.IndexOfComponentItem(
3752 Component: TWinControl): integer;
3753var
3754 i:integer;
3755 item: TComplexDataItem;
3756begin
3757 for i := 0 to FComponentList.Count -1 do
3758 begin
3759 item := TComplexDataItem(FComponentList[i]);
3760 if item.FComponent = Component then
3761 begin
3762 Result := i;
3763 exit;
3764 end;
3765 end;
3766 Result := -1;
3767end;
3768
3769function TVA508ComplexComponentManager.IndexOfSubComponentXRef(
3770 Component: TWinControl): integer;
3771var
3772 i:integer;
3773 item: TComplexDataItem;
3774begin
3775 for i := 0 to FSubComponentXRef.Count -1 do
3776 begin
3777 item := TComplexDataItem(FSubComponentXRef[i]);
3778 if item.FSubComponent = Component then
3779 begin
3780 Result := i;
3781 exit;
3782 end;
3783 end;
3784 Result := -1;
3785end;
3786
3787procedure TVA508ComplexComponentManager.ComponentNotifyEvent(AComponent: TComponent;
3788 Operation: TOperation);
3789var
3790 idx: integer;
3791begin
3792 if (Operation = opRemove) and assigned(AComponent) and (AComponent is TWinControl) then
3793 begin
3794 ClearSubControls(TWinControl(AComponent));
3795 idx := IndexOfComponentItem(TWinControl(AComponent));
3796 if idx >= 0 then
3797 FComponentList.Delete(idx);
3798 end;
3799end;
3800
3801procedure TVA508ComplexComponentManager.SubComponentNotifyEvent(
3802 AComponent: TComponent; Operation: TOperation);
3803var
3804 idx: integer;
3805 Parent: TWinControl;
3806 item: TComplexDataItem;
3807begin
3808 if (Operation = opRemove) and assigned(AComponent) and (AComponent is TWinControl) then
3809 begin
3810 idx := IndexOfSubComponentXRef(TWinControl(AComponent));
3811 if idx >= 0 then
3812 begin
3813 item := TComplexDataItem(FSubComponentXRef[idx]);
3814 Parent := item.FComponent;
3815 RemoveSubControl(Parent, TWinControl(AComponent));
3816 end;
3817 end;
3818end;
3819
3820function TVA508ComplexComponentManager.SubControlCount(Component: TWinControl): integer;
3821begin
3822 if assigned(Component) then
3823 Result := GetSubComponentList(Component).Count
3824 else
3825 Result := 0;
3826end;
3827
3828initialization
3829
3830finalization
3831 FreeGlobalVars;
3832
3833end.
3834
Note: See TracBrowser for help on using the repository browser.