unit VA508AccessibilityManager;

interface
{ TODO -oJeremy Merrill -c508 :Remove Main Form from component list}
{ TODO -oJeremy Merrill -c508 :
Figure out a way to handle a component being renamed on a parent form - the child form now
references the component under a different name }
uses
  Windows, Messages, SysUtils, Classes, Controls, StdCtrls, Forms, Contnrs, Dialogs,
  StrUtils, Buttons, ComCtrls, ExtCtrls, TypInfo, Graphics, VAClasses, VAUtils,
  VA508AccessibilityConst;

const
  VA508AccessibilityManagerVersion = '1.10';

type
  TVA508AccessibilityManager = class;
  TVA508AccessibilityCollection = class;
  TVA508ComponentManager = class;

  TVA508AccessibilityStatus = (stsOK, stsNoTabStop, stsDefault, stsNoData);

  TVA508AccessibilityItem = class(TCollectionItem)
  private
    FComponent: TWinControl;
    FComponentManager: TVA508ComponentManager;
    FLabel: TLabel;
    FProperty: string;
    FText: string;
    FDefault: boolean;
    FStatus: TVA508AccessibilityStatus;
    procedure SetComponent(const Component: TWinControl);
    procedure InitComponent(const Component: TWinControl; FromManager: boolean);
    procedure SetLabel(const Value: TLabel);
    procedure SetProperty(const Value: string);
    procedure SetText(const Value: string);
    function Parent: TVA508AccessibilityCollection;
    procedure SetDefault(const Value: boolean);
  protected
    function GetDisplayName: string; override;
  public
    constructor Create(Collection: TCollection); override;
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
    procedure UpdateStatus;
    function Manager: TVA508AccessibilityManager;
    property Status: TVA508AccessibilityStatus read FStatus write FStatus;
    property ComponentManager: TVA508ComponentManager read FComponentManager write FComponentManager;
  published
    property AccessLabel: TLabel read FLabel write SetLabel;
    property AccessProperty: string read FProperty write SetProperty;
    property AccessText: string read FText write SetText;
    property Component: TWinControl read FComponent write SetComponent;
    property UseDefault: boolean read FDefault write SetDefault;
    property DisplayName: string read GetDisplayName;
  end;

  TVA508AccessibilityCollection = class(TCollection)
  private
    FRegistry: TStringList;
    FManager: TVA508AccessibilityManager;
    FNotifier: TVANotificationEventComponent;
    procedure ComponentNotifyEvent(AComponent: TComponent; Operation: TOperation);
  protected
    function IsComponentRegistered(Component: TWinControl): boolean;
    procedure RegisterComponent(Component: TWinControl; Item: TVA508AccessibilityItem);
    procedure UnregisterComponent(Component: TWinControl);
    function GetItem(Index: Integer): TVA508AccessibilityItem;
    procedure SetItem(Index: Integer; Value: TVA508AccessibilityItem);
    function GetOwner: TPersistent; override;
//    procedure Update(Item: TCollectionItem); override;
  public
    constructor Create(Manager: TVA508AccessibilityManager);
    destructor Destroy; override;
    procedure EnsureItemExists(Component: TWinControl);
    function FindItem(Component: TWinControl; CreateIfNotFound: boolean = true): TVA508AccessibilityItem;
    function Add: TVA508AccessibilityItem;
    property Items[Index: Integer]: TVA508AccessibilityItem read GetItem write SetItem; default;
  end;

  TVA508AccessibilityManager = class(TComponent)
  private
    FDFMData: TObjectList;
    FData: TVA508AccessibilityCollection;
    function GetAccessLabel(Component: TWinControl): TLabel;
    function GetAccessProperty(Component: TWinControl): String;
    function GetAccessText(Component: TWinControl): String;
    procedure SetAccessLabel(Component: TWinControl; const Value: TLabel);
    procedure SetAccessProperty(Component: TWinControl; const Value: String);
    procedure SetAccessText(Component: TWinControl; const Value: String);
    function GetRootComponent(Component: TComponent; var PropertyName: String): TComponent;
    function GetDefaultStringProperty(AComponent: TWinControl): String;
    procedure Initialize;
    function GetData: TVA508AccessibilityCollection;
    function OwnerCheck(Component: TComponent): boolean;
    function FindComponentOnForm(ComponentName: String): TComponent;
    procedure ReadData(Reader: TReader);
    procedure WriteData(Writer: TWriter);
    function GetUseDefault(Component: TWinControl): boolean;
    procedure SetUseDefault(Component: TWinControl; const Value: boolean);
    function GetComponentManager(
      Component: TWinControl): TVA508ComponentManager;
    procedure SetComponentManager(Component: TWinControl;
      const Value: TVA508ComponentManager);
  protected
    procedure DefineProperties(Filer: TFiler); override;
    procedure Loaded; override;
    function GetPropertList(Component: TWinControl): TStrings;
    function IsPropertyNameValid(Component: TWinControl; PropertyName: String): boolean;
    function ScreenReaderInquiry(Component: TWinControl): string;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    function GetComponentName(AComponent: TComponent): String;
    procedure GetLabelStrings(list: TStringList);
    procedure GetProperties(Component: TWinControl; list: TStrings);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure RefreshComponents;
    property AccessText[Component: TWinControl]: string
                      read GetAccessText
                      write SetAccessText;
    property AccessLabel[Component: TWinControl]: TLabel
                      read GetAccessLabel
                      write SetAccessLabel;
    property AccessProperty[Component: TWinControl]: string
                      read GetAccessProperty
                      write SetAccessProperty;
    property ComponentManager[Component: TWinControl]: TVA508ComponentManager
                      read GetComponentManager
                      write SetComponentManager;
    property UseDefault[Component: TWinControl]: boolean
                      read GetUseDefault
                      write SetUseDefault;
  published
    property AccessData: TVA508AccessibilityCollection read GetData write FData stored FALSE;
  end;

  IVA508CustomDefaultCaption = interface(IInterface)
  ['{ED1E68FD-5432-4C9D-A250-2069F3A2CABE}']
    function GetDefaultCaption: string;
  end;

  TVA508ScreenReaderEvent = procedure(Sender: TObject; var Text: String) of object;
  TVA508ScreenReaderItemEvent = procedure(Sender: TObject; var Item: TObject) of object;

  TVA508ComponentAccessibility = class(TComponent)
  private
    FOnComponentNameQuery: TVA508ScreenReaderEvent;
    FOnCaptionQuery: TVA508ScreenReaderEvent;
    FOnValueQuery: TVA508ScreenReaderEvent;
    FOnStateQuery: TVA508ScreenReaderEvent;
    FOnInstructionsQuery: TVA508ScreenReaderEvent;
    FOnItemInstructionsQuery: TVA508ScreenReaderEvent;
    FOnItemQuery: TVA508ScreenReaderItemEvent;
    FComponentName: string;
    FCaption: string;
    FInstructions: string;
    FItemInstructions: string;
    FComponent: TWinControl;
    procedure SetComponent(const Value: TWinControl);
  protected
    { Protected declarations }
  public
    { Public declarations }
  published
    { Published declarations }
    constructor Create(AOwner: TComponent); override;
    property Component: TWinControl read FComponent write SetComponent;
    property OnComponentNameQuery: TVA508ScreenReaderEvent read FOnComponentNameQuery write FOnComponentNameQuery;
    property OnCaptionQuery: TVA508ScreenReaderEvent read FOnCaptionQuery write FOnCaptionQuery;
    property OnValueQuery: TVA508ScreenReaderEvent read FOnValueQuery write FOnValueQuery;
    property OnStateQuery: TVA508ScreenReaderEvent read FOnStateQuery write FOnStateQuery;
    property OnInstructionsQuery: TVA508ScreenReaderEvent read FOnInstructionsQuery write FOnInstructionsQuery;
    property OnItemInstructionsQuery: TVA508ScreenReaderEvent read FOnItemInstructionsQuery write FOnItemInstructionsQuery;
    property OnItemQuery: TVA508ScreenReaderItemEvent read FOnItemQuery write FOnItemQuery;
    property ComponentName: string read FComponentName write FComponentName;
    property Caption: string read FCaption write FCaption;
    property Instructions: string read FInstructions write FInstructions;
    property ItemInstructions: string read FItemInstructions write FItemInstructions;
  end;

// automatically freed when component is destroyed
  TManagedType = (mtNone, mtCaption, mtComponentName, mtInstructions, mtValue, mtData,
                  mtState, mtStateChange, // NOTE - should ALWAYS use mtStateChange when mtState is used!!!
                  mtItemChange, mtItemInstructions, mtComponentRedirect);
  TManagedTypes = set of TManagedType;

  TVA508ComponentManager = class(TObject)
  private
    FManagedTypes: TManagedTypes;
  protected
    constructor Create(ManagedTypes: TManagedTypes); overload;
  public
    constructor Create; overload; virtual; abstract;
    function GetCaption(Component: TWinControl): string; virtual;
    function GetComponentName(Component: TWinControl): string; virtual;
    function GetInstructions(Component: TWinControl): string; virtual;
    function GetItemInstructions(Component: TWinControl): string; virtual;
    function GetValue(Component: TWinControl): string; overload; virtual;
    function GetData(Component: TWinControl; Value: string): string; overload; virtual;
    function GetState(Component: TWinControl): string; virtual;
    function GetItem(Component: TWinControl): TObject; virtual;
    function ManageCaption(Component: TWinControl): boolean; virtual;
    function ManageComponentName(Component: TWinControl): boolean; virtual;
    function ManageInstructions(Component: TWinControl): boolean; virtual;
    function ManageItemInstructions(Component: TWinControl): boolean; virtual;
    function ManageValue(Component: TWinControl): boolean; virtual;
    function ManageData(Component: TWinControl): boolean; virtual;
    function ManageState(Component: TWinControl): boolean; virtual;
    function MonitorForStateChange(Component: TWinControl): boolean; virtual;
    function MonitorForItemChange(Component: TWinControl): boolean; virtual;
    function RedirectsComponent(Component: TWinControl): boolean; virtual;
    function Redirect(Component: TWinControl; var ManagedType: TManagedType): TWinControl; virtual;
  end;

  TVA508StaticText = class;

  TVA508ChainedLabel = class(TLabel)
  private
    FStaticLabelParent: TVA508StaticText;
    FPreviousLabel: TControl;
    FNextLabel: TVA508ChainedLabel;
    procedure SetNextLabel(const Value: TVA508ChainedLabel);
  protected
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    procedure Paint; override;
  public
    property NextLabel: TVA508ChainedLabel read FNextLabel write SetNextLabel;
  end;

  TVA508StaticText = class(TPanel)
  private
    FLabel: TLabel;
    FOnEnter: TNotifyEvent;
    FOnExit: TNotifyEvent;
    FNextLabel: TVA508ChainedLabel;
    FDeletingChain: boolean;
    FInitTabStop: boolean;
    procedure DeleteChain(FromLabel, ToLabel: TVA508ChainedLabel);
    procedure SetNextLabel(const Value: TVA508ChainedLabel);
    function GetLabelCaption: string;
    procedure SetLabelCaption(const Value: string);
    function GetRootName: string;
    procedure SetRootName(const Value: string);
    function GetShowAccelChar: boolean;
    procedure SetShowAccelChar(const Value: boolean);
    procedure UpdateSize;
    procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
    procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
    function GetAlignment: TAlignment;
    procedure SetAlignment(const Value: TAlignment);
  protected
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    procedure DoEnter; override;
    procedure DoExit; override;
    procedure Paint; override;
    procedure SetParent(AParent: TWinControl); override;
    property StaticLabel: TLabel read FLabel;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure InvalidateAll;
    property NextLabel: TVA508ChainedLabel read FNextLabel write SetNextLabel;
  published
    property TabStop default false;
    property OnEnter: TNotifyEvent read FOnEnter write FOnEnter;
    property OnExit: TNotifyEvent read FOnExit write FOnExit;
    property Caption: string read GetLabelCaption write SetLabelCaption;
    property Name: string read GetRootName write SetRootName;
    property ShowAccelChar: boolean read GetShowAccelChar write SetShowAccelChar;
    property Alignment: TAlignment read GetAlignment write SetAlignment;
  end;

  TVA508SilentComponent = class(TVA508ComponentManager)
  public
    function GetComponentName(Component: TWinControl): string; override;
    function GetInstructions(Component: TWinControl): string; override;
    function GetValue(Component: TWinControl): string; override;
    function GetState(Component: TWinControl): string; override;
  end;

  TVA508AlternateHandleFunc = function(Component: TWinControl): HWnd;

  TVA508ManagedComponentClass = class(TVA508ComponentManager)
  private
    FClassType: TWinControlClass;
    FManageDescendentClasses: boolean;
  protected
    constructor Create(AClassType: TWinControlClass; ManageTypes: TManagedTypes;
                       AManageDescendentClasses: boolean = FALSE); overload;
    property ManageDescendentClasses: boolean read FManageDescendentClasses write FManageDescendentClasses;
  public
    property ComponentClassType: TWinControlClass read FClassType;
  end;

  TVA508ComplexComponentManager = class(TObject)
  private
    FComponentList: TObjectList;
    FSubComponentXRef: TObjectList;
    FComponentClass: TWinControlClass;
    FComponentNotifier: TVANotificationEventComponent;
    FSubComponentNotifier: TVANotificationEventComponent;
    procedure ComponentNotifyEvent(AComponent: TComponent; Operation: TOperation);
    procedure SubComponentNotifyEvent(AComponent: TComponent; Operation: TOperation);
    function IndexOfComponentItem(Component: TWinControl): integer;
    function IndexOfSubComponentXRef(Component: TWinControl): integer;
    function GetSubComponentList(Component: TWinControl): TList;
  protected
    procedure ClearSubControls(Component: TWinControl);
    procedure AddSubControl(ParentComponent, SubControl: TWinControl;
                            AccessibilityManager: TVA508AccessibilityManager);
    procedure RemoveSubControl(ParentComponent, SubControl: TWinControl);
  public
    constructor Create(AComponentClass: TWinControlClass); overload;
    destructor Destroy; override;
    procedure Refresh(Component: TWinControl;
                      AccessibilityManager: TVA508AccessibilityManager); virtual; abstract;
    function SubControlCount(Component: TWinControl): integer;
    function GetSubControl(Component: TWinControl; Index: integer): TWinControl;
    property ComponentClass: TWinControlClass read FComponentClass;
  end;


procedure RegisterAlternateHandleComponent(ComponentClass: TWinControlClass;
                                           AlternateHandleFunc: TVA508AlternateHandleFunc);
procedure RegisterComplexComponentManager(Manager: TVA508ComplexComponentManager);
procedure RegisterManagedComponentClass(Manager: TVA508ManagedComponentClass);
procedure RegisterMSAAQueryClassProc(MSAAClass: TWinControlClass; Proc: TVA508QueryProc);
procedure RegisterMSAAQueryListClassProc(MSAAClass: TWinControlClass; Proc: TVA508ListQueryProc);

const
  ComponentManagerSilentText = ' '; // '' does not silence the screen reader

  AccessibilityLabelPropertyName    = 'AccessLabel';
  AccessibilityPropertyPropertyName = 'AccessProperty';
  AccessibilityTextPropertyName     = 'AccessText';
  AccessibilityUseDefaultPropertyName = 'UseDefault';
//  AccessibilityEventPropertyName    = 'OnAccessRequest';   // AccessEvent

  AccessDataStatusText = 'Status';
  AccessDataLabelText = 'Label';
  AccessDataPropertyText = 'Property';
  AccessDataTextText = 'Text';
//  AccessDataEventText = 'Event';
  AccessDataComponentText = 'Component';

  VA508DataPropertyName = 'AccessData';
  VA508DFMDataPropertyName = 'Data';

  EQU = ' = ';
  EQU_LEN = length(EQU);

type
  TDefaultStringPropertyValuePair = record
    ClassType: TWinControlClass;
    PublishedPropertyName: String;
  end;

const
  CaptionedControlClassCount = 6;
  CaptionProperty = 'Caption';
  ControlsWithDefaultPropertySettings: array[1..CaptionedControlClassCount] of TDefaultStringPropertyValuePair =

   ((ClassType: TCustomForm; PublishedPropertyName: CaptionProperty),
  // includes TButton, TBitBtn, TCheckBox, TRadioButton, TDBCheckBox, and TGroupButton
    (ClassType: TButtonControl; PublishedPropertyName: CaptionProperty),
  // includes TPanel, TFlowPanel and TGridPanel, but not TDBNAvigator or TDecisionPivot
  //                               because they do not have a published Caption property
    (ClassType: TCustomPanel; PublishedPropertyName: CaptionProperty),
  // Includes TGroupBox, TRadioGroup and TDBRadioGroupBox
    (ClassType: TCustomGroupBox; PublishedPropertyName: CaptionProperty),
  // TStaticText only
    (ClassType: TCustomStaticText; PublishedPropertyName: CaptionProperty),
  // TLabeledEdit only
    (ClassType: TCustomLabeledEdit; PublishedPropertyName: 'EditLabel.' + CaptionProperty));

implementation

// VA508DelphiCompatibility added to ensure initialization section runs
uses ComObj, VA508Classes, VA508AccessibilityRouter, VA508DelphiCompatibility,
  VA508ScreenReaderDLLLinker, Types, VA508MSAASupport;

type
  TVA508RegistrationScreenReader = class(TVA508ScreenReader);

  TComponentHelper = class(TObject)
  private
    FRedirectedComponent: TWinControl;
    FRedirectedHelper: TComponentHelper;
    FRedirectedHelperType: TManagedType;
    FHandleKey: string;
    FComponent: TWinControl;
    FManager: TVA508AccessibilityManager;
    FManagedClassData: TVA508ManagedComponentClass;
    FFieldObject: TVA508ComponentAccessibility;
    FComponentManager: TVA508ComponentManager;
    FComplexManager: TVA508ComplexComponentManager;
    procedure ClearRedirect;
    function Redirect(RedirectType: TManagedType): boolean;
  published
  public
    constructor Create;
    destructor Destroy; override;
    procedure InitializeComponentManager;
    function GetCaption(var DataResult: LongInt): string;
    function GetComponentName(var DataResult: LongInt): string;
    function GetInstructions(var DataResult: LongInt): string;
    function GetItemInstructions(var DataResult: LongInt): string;
    function GetValue(var DataResult: LongInt): string;
    function GetData(var DataResult: LongInt; Value: string): string;
    function GetState(var DataResult: LongInt): string;
    function GetItem: TObject;
    function ManageComponentName: boolean;
    function ManageInstructions: boolean;
    function ManageItemInstructions: boolean;
    function ManageValue: boolean;
    function ManageData: boolean;
    function MonitorForStateChange: boolean;
    function MonitorForItemChange: boolean;
    function ManageCaption: boolean;
    function StandardComponent: boolean;
    property ComponentManager: TVA508ComponentManager read FComponentManager;
    property HandleKey: string read FHandleKey write FHandleKey;
    property Component: TWinControl read FComponent write FComponent;
    property Manager: TVA508AccessibilityManager read FManager write FManager;
    property ManagedClassData: TVA508ManagedComponentClass read FManagedClassData write FManagedClassData;
    property FieldObject: TVA508ComponentAccessibility read FFieldObject write FFieldObject;
    property ComplexManager: TVA508ComplexComponentManager read FComplexManager write FComplexManager;
  end;

  TComponentData = record
    Handle:           HWND;
    CaptionQueried:   boolean;
    ValueQueried:     boolean;
    StateQueried:     boolean;
    ItemInstrQueried: boolean;
    Caption:          string;
    Item:             TObject;
    State:            string;
    ItemInstructions: string;
  end;

const
  IIDelim = '^';

  NewComponentData: TComponentData =
    (Handle:           0;
     CaptionQueried:   FALSE;
     ValueQueried:     FALSE;
     StateQueried:     FALSE;
     ItemInstrQueried: FALSE;
     Caption:          '';
     Item:             nil;
     State:            '';
     ItemInstructions: IIDelim);
type
  TScreenReaderEventType = (sreCaption, sreValue, sreState, sreInstructions, sreItemInstructions);

  TVAGlobalComponentRegistry = class(TObject)
  private
    class var
      FActive: boolean;
      FGetMsgHookHandle: HHOOK;
  private
    FCurrentHelper: TComponentHelper;
    FDestroying: boolean;
    FComponentRegistry: TStringList;
    FHandlesXREF: TStringList;
    FHandlesPending: TStringList;
    FPendingRecheckTimer: TTimer;
    FCheckingPendingList: boolean;
    FUnregisteringComponent: boolean;
    FComponentData: TComponentData;
    FPendingFieldObjects: TStringList;
    function GetComponentHelper(WindowHandle: HWND): TComponentHelper;
    procedure CheckForChangeEvent;
    function GetComponentHandle(Component: TWinControl): Hwnd;
    function HasHandle(Component: TWinControl; var HandleKey: String): boolean;
    function GetCompKey(Component: TWinControl): String;
    procedure UpdateHandles(WindowHandle: HWnd; var HandlesModified: boolean);
  protected
    procedure TimerEvent(Sender: TObject);
    procedure ComponentDataNeededEvent(const WindowHandle: HWND; var DataStatus: LongInt;
        var Caption: PChar; var Value: PChar; var Data: PChar; var ControlType: PChar;
        var State: PChar; var Instructions: PChar; var ItemInstructions: PChar);
    procedure RegisterMSAA(Component: TWinControl);
    procedure UnregisterMSAA(Component: TWinControl);
  public
    constructor Create;
    destructor Destroy; override;
    function GetFieldObject(Component: TWinControl): TVA508ComponentAccessibility;
    procedure RegisterFieldObject(Component: TWinControl; FieldObject: TVA508ComponentAccessibility;
                                    Adding: boolean);
    procedure RegisterComponent(component: TWinControl; Manager: TVA508AccessibilityManager);
    procedure UnregisterComponent(component: TWinControl);
  end;

  TDFMData = class(TObject)
  private
    ComponentName: string;
    LabelName: string;
    PropertyName: string;
    Text: string;
    Status: TVA508AccessibilityStatus;
//    Event: TVA508ComponentScreenReaderEvent;
  end;

  TMSAAData = class(TObject)
  private
    MSAAClass: TWinControlClass;
    Proc: TVA508QueryProc;    
    ListProc: TVA508ListQueryProc;
  end;

{ TVA508AccessibilityItem }

const
  INVALID_COMPONENT_ERROR = 'Internal Error - Invalid Component';
  NAME_DELIM = '.';

var
  MasterPropertyList: TStringList = nil;
  GlobalRegistry: TVAGlobalComponentRegistry = nil;
  AltHandleClasses: TObjectList = nil;
  ManagedClasses: TObjectList = nil;
  ComplexClasses: TObjectList = nil;
  MSAAQueryClasses: TObjectList = nil;

procedure CreateGlobalRegistry;
begin
  if ScreenReaderSystemActive and (not assigned(GlobalRegistry)) then
    GlobalRegistry := TVAGlobalComponentRegistry.Create;
end;

procedure CreateGlobalVars;
begin
  if not assigned(MasterPropertyList) then
    MasterPropertyList := TStringList.create;
  CreateGlobalRegistry;    
end;

procedure FreeGlobalVars;
begin
  if assigned(MasterPropertyList) then
    FreeAndNilTStringsAndObjects(MasterPropertyList);
  if assigned(GlobalRegistry) then
    FreeAndNil(GlobalRegistry);
  if assigned(AltHandleClasses) then
    FreeAndNil(AltHandleClasses);
  if assigned(ManagedClasses) then
    FreeAndNil(ManagedClasses);
  if assigned(ComplexClasses) then
    FreeAndNil(ComplexClasses);
  if assigned(MSAAQueryClasses) then
    FreeAndNil(MSAAQueryClasses);
end;

procedure TVA508AccessibilityItem.Assign(Source: TPersistent);
var
  item: TVA508AccessibilityItem;
begin
  if Source is TVA508AccessibilityItem then
  begin
    item := TVA508AccessibilityItem(Source);
    FComponent := item.FComponent;
    FComponentManager := item.ComponentManager;
    FLabel := item.FLabel;
    FProperty := item.FProperty;
    FText := item.FText;
    FDefault := item.FDefault;
    FStatus := item.FStatus;
  end
  else inherited Assign(Source);
end;

constructor TVA508AccessibilityItem.Create(Collection: TCollection);
begin
  inherited Create(Collection);
end;

destructor TVA508AccessibilityItem.Destroy;
begin
  Parent.UnregisterComponent(FComponent);
  if assigned(FComponentManager) then
    FreeAndNil(FComponentManager);
  inherited;
end;

function TVA508AccessibilityItem.GetDisplayName: string;
begin
  if assigned(FComponent) then
  begin
    Result := Manager.GetComponentName(FComponent) +
              '  (' + FComponent.ClassName + ')'
  end
  else
    Result := TVA508AccessibilityItem.ClassName;
end;

procedure TVA508AccessibilityItem.InitComponent(const Component: TWinControl; FromManager: boolean);
begin
  FComponent := Component;
  if FromManager and (not (csReading in Manager.ComponentState)) then
    FDefault := TRUE;  
end;

function TVA508AccessibilityItem.Manager: TVA508AccessibilityManager;
begin
  Result := TVA508AccessibilityCollection(Collection).FManager;
end;

function TVA508AccessibilityItem.Parent: TVA508AccessibilityCollection;
begin
  Result := TVA508AccessibilityCollection(Collection);
end;

procedure TVA508AccessibilityItem.SetComponent(const Component: TWinControl);
begin
  if (FComponent <> Component) and
    (([csDesigning, csFixups, csLoading, csReading, csUpdating] * Manager.ComponentState) <> []) and
    (not Parent.IsComponentRegistered(Component)) then
  begin
    Parent.UnregisterComponent(FComponent);
    InitComponent(Component, FALSE);
    Parent.RegisterComponent(Component, Self);
  end;
end;

procedure TVA508AccessibilityItem.SetDefault(const Value: boolean);
begin
  if FDefault <> Value then
  begin
    FDefault := Value;
    if FDefault then
    begin
      FLabel := nil;
      FText := '';
      FProperty := '';
    end
    else if (FProperty = '') and (not (csReading in Manager.ComponentState)) then
      FProperty := Manager.GetDefaultStringProperty(FComponent);
  end;
end;

procedure TVA508AccessibilityItem.SetLabel(const Value: TLabel);
begin
  if FLabel <> Value then
  begin
    FLabel := Value;
    if assigned(FLabel) then
    begin
      FProperty := '';
      FText := '';
      FDefault := FALSE;
    end;
  end;  
end;

procedure TVA508AccessibilityItem.SetProperty(const Value: string);
begin
  if (FProperty <> Value) and 
        ((Value = '') or (csreading in Manager.ComponentState) or
          Manager.IsPropertyNameValid(Component, Value)) then
  begin
    FProperty := Value;
    if (FProperty <> '') then
    begin
      FLabel := nil;
      FText := '';
      FDefault := FALSE;
    end;
  end;
end;

procedure TVA508AccessibilityItem.SetText(const Value: string);
begin
  if FText <> Value then
  begin
    FText := Value;
    if FText <> '' then
    begin
      FLabel := nil;
      FProperty := '';
      FDefault := FALSE;
    end;
  end;
end;

procedure TVA508AccessibilityItem.UpdateStatus;
begin
  FStatus := stsNoData;
  if assigned(FComponent) then
  begin
    if FDefault then
      FStatus := stsDefault
    else
{ TODO : FIX THIS!!!!!!!!!!!!!!!! }    
    if assigned(FLabel) or (AccessProperty <> '') or (FText <> '') then //or assigned(FEvent) then
      FStatus := stsOK
    else
    if FComponent.TabStop = FALSE then
      FStatus := stsNoTabStop;
  end;
end;

{ TVA508AccessibilityCollection }

function TVA508AccessibilityCollection.Add: TVA508AccessibilityItem;
begin
  Result := TVA508AccessibilityItem(inherited Add);
end;

procedure TVA508AccessibilityCollection.ComponentNotifyEvent(
  AComponent: TComponent; Operation: TOperation);
var
  item: TVA508AccessibilityItem;
begin
  if (Operation = opRemove) and (AComponent is TWinControl) then
  begin
    if ScreenReaderSystemActive then
      GlobalRegistry.UnregisterComponent(TWinControl(AComponent));
    item := FindItem(TWinControl(AComponent), FALSE);
    if assigned(item) then
      item.Free;
  end;
end;

constructor TVA508AccessibilityCollection.Create(
  Manager: TVA508AccessibilityManager);
begin
  inherited Create(TVA508AccessibilityItem);
  FManager := Manager;
  FRegistry := TStringList.Create;
  FRegistry.Sorted := TRUE;
  FRegistry.Duplicates := dupAccept; // speeds things up
  FNotifier := TVANotificationEventComponent.NotifyCreate(nil, ComponentNotifyEvent);
end;

destructor TVA508AccessibilityCollection.Destroy;
begin
  FNotifier.OnNotifyEvent := nil;
  FNotifier.Free;
  FRegistry.Free;
  inherited;
end;

procedure TVA508AccessibilityCollection.EnsureItemExists(
  Component: TWinControl);
begin
  FindItem(Component);
end;

function TVA508AccessibilityCollection.FindItem(
  Component: TWinControl; CreateIfNotFound: boolean = true): TVA508AccessibilityItem;
var
  key: string;
  idx: integer;
begin
  Result := nil;
  if assigned(Component) then
  begin
    key := FastIntToHex(Integer(Component));
    idx := FRegistry.IndexOf(key);
    if idx < 0 then
    begin
      if CreateIfNotFound then
      begin
        Result := Add;
        Result.InitComponent(Component, TRUE);
        RegisterComponent(Component, Result);
      end;
    end
    else
      Result := TVA508AccessibilityItem(FRegistry.Objects[idx]);
  end;
end;

function TVA508AccessibilityCollection.GetItem(
  Index: Integer): TVA508AccessibilityItem;
begin
  Result := TVA508AccessibilityItem(inherited GetItem(Index));
end;

function TVA508AccessibilityCollection.GetOwner: TPersistent;
begin
  Result := FManager;
end;

function TVA508AccessibilityCollection.IsComponentRegistered(
  Component: TWinControl): boolean;
begin
  if assigned(Component) then
    Result := FRegistry.IndexOf(FastIntToHex(Integer(Component))) >= 0
  else
    Result := TRUE;
end;

procedure TVA508AccessibilityCollection.UnregisterComponent(
  Component: TWinControl);
var
  key: string;
  idx: integer;
begin
  if ScreenReaderSystemActive then
    GlobalRegistry.UnregisterComponent(Component);
  if not assigned(Component) then exit;
  key := FastIntToHex(Integer(Component));
  idx := FRegistry.IndexOf(key);
  if idx >= 0 then
  begin
    FRegistry.Delete(idx);
    Component.RemoveFreeNotification(FNotifier);
  end;
end;

procedure TVA508AccessibilityCollection.SetItem(Index: Integer;
  Value: TVA508AccessibilityItem);
begin
  inherited SetItem(Index, Value);
end;
{
procedure TVA508AccessibilityCollection.Update(Item: TCollectionItem);
begin
  inherited;
end;
}
procedure TVA508AccessibilityCollection.RegisterComponent(Component: TWinControl; Item: TVA508AccessibilityItem);
var
  key: string;
begin
  if ScreenReaderSystemActive then
    GlobalRegistry.RegisterComponent(Component, FManager);
  if (not assigned(Component)) or (not assigned(item)) then exit;
  key := FastIntToHex(Integer(Component));
  if FRegistry.IndexOf(key) < 0 then
  begin
    FRegistry.AddObject(key, Item);
    Component.FreeNotification(FNotifier);
  end;
end;

{ TVA508AccessibilityManager }

constructor TVA508AccessibilityManager.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  VA508ComponentCreationCheck(Self, AOwner, FALSE, FALSE);
  CreateGlobalVars;
  FData := TVA508AccessibilityCollection.Create(Self);
  Initialize;
end;

destructor TVA508AccessibilityManager.Destroy;
begin
  VA508ComponentDestructionCheck(Self);
  if assigned(FData) then  
    FData.Free;
  if assigned(FDFMData) then
    FreeAndNil(FDFMData);
  inherited;
end;

function TVA508AccessibilityManager.FindComponentOnForm(
  ComponentName: String): TComponent;
var
  p: integer;
  comp: TComponent;
  name: String;

  function FindOwnedComponent(AComponent: TComponent; ComponentName: String): TComponent;
  var
    i: integer;
  begin
    Result := nil;
    if AnsiCompareText(ComponentName, AComponent.Name)= 0 then
    begin
      Result := AComponent;
      exit;
    end;
    for i := 0 to AComponent.ComponentCount - 1 do
    begin
      if (AnsiCompareText(ComponentName, AComponent.Components[i].Name)= 0) then
      begin
        Result := AComponent.Components[i];
        exit;
      end;
    end;
  end;

begin
  if RightStr(ComponentName,1) <> NAME_DELIM then
    ComponentName := ComponentName + NAME_DELIM;
  Result := nil;
  comp := owner;
  repeat
    p := pos(NAME_DELIM, ComponentName);
    if p > 0 then
    begin
      name := copy(ComponentName, 1, p-1);
      delete(ComponentName, 1, p);
      comp := FindOwnedComponent(comp, name);
    end;
  until p = 0;
  if assigned(comp) then
    Result := comp;      
end;

function TVA508AccessibilityManager.GetAccessLabel(
  Component: TWinControl): TLabel;
begin
  Result := FData.FindItem(Component).AccessLabel;
end;

function TVA508AccessibilityManager.GetAccessProperty(
  Component: TWinControl): String;
begin
  Result := FData.FindItem(Component).AccessProperty;
end;

function TVA508AccessibilityManager.GetAccessText(
  Component: TWinControl): String;
begin
  Result := FData.FindItem(Component).AccessText;
end;

function TVA508AccessibilityManager.GetComponentManager(
  Component: TWinControl): TVA508ComponentManager;
begin
  Result := FData.FindItem(Component).ComponentManager;
end;

function TVA508AccessibilityManager.GetComponentName(
  AComponent: TComponent): String;
var
  comp: TComponent;

  procedure error;
  begin
    raise EVA508AccessibilityException.Create(INVALID_COMPONENT_ERROR);
  end;

  function BasicComponentCheck(var Name: string): boolean;
  begin
    Result := TRUE;
    Name := '';
    if (not assigned(AComponent)) then error;
    if AComponent = owner then
    begin
      Name := AComponent.Name;
      exit;
    end;
    if not assigned(AComponent.Owner) then error;
    if (AComponent.owner = owner) then
      Name := AComponent.Name
    else
      Result := FALSE;
  end;

begin
  if BasicComponentCheck(Result) then exit;
  comp := AComponent;
  Result := AComponent.Name;
  while assigned(comp.Owner) and (comp.Owner <> Owner) do
  begin
    comp := comp.Owner;
    Result := comp.Name + NAME_DELIM + Result;
  end;
  if not assigned(comp.Owner) then error;
end;

function TVA508AccessibilityManager.GetData: TVA508AccessibilityCollection;
begin
  Result := FData;
end;

function TVA508AccessibilityManager.GetDefaultStringProperty(AComponent: TWinControl): String;
var
  i: integer;
  ValuePair: TDefaultStringPropertyValuePair;
  PropName: string;
begin
  Result := '';
  if not assigned(AComponent) then exit;  
  for i := 1 to CaptionedControlClassCount do
  begin
    ValuePair := ControlsWithDefaultPropertySettings[i];
    if AComponent is ValuePair.ClassType then
    begin
      PropName := ValuePair.PublishedPropertyName;
      if IsPropertyNameValid(AComponent, PropName) then
        Result := PropName;
      break;
    end;
  end;
end;

procedure TVA508AccessibilityManager.GetLabelStrings(list: TStringList);

  procedure AddLabels(Component: TWinControl);
  var
    i: integer;
    control: TControl;
  begin
    for I := 0 to Component.ControlCount-1 do
    begin
      control := Component.Controls[i];
      if control is TLabel then
        list.Add(GetComponentName(control) + '="' + TLabel(control).Caption + '"')
      else
      begin
        if (control is TWinControl) and
           ((csAcceptsControls in control.ControlStyle) or (control is TFrame)) then
            AddLabels(TWinControl(control));
      end;
    end;
  end;

begin
  AddLabels(TWinControl(Owner));
  list.Sort;
end;

procedure TVA508AccessibilityManager.GetProperties(Component: TWinControl; list: TStrings);
begin
  list.Assign(GetPropertList(Component));
end;

function TVA508AccessibilityManager.GetPropertList(Component: TWinControl): TStrings;
const
//  STRING_FILTER = [tkChar, tkString, tkWChar, tkLString, tkWString];
  STRING_FILTER = [tkString, tkLString, tkWString];
var
  pList: PPropList;
  i, idx, pCount, pSize: Integer;
  ClsInfo: Pointer;
  name: string;
  info: TStringList;
begin
  idx := MasterPropertyList.IndexOf(Component.ClassName);
  if idx < 0 then
  begin
    info := TStringList.Create;
    try
      ClsInfo := Component.ClassInfo;
      pCount := GetPropList(ClsInfo, STRING_FILTER, nil);
      pSize := pCount * SizeOf(Pointer);
      GetMem(pList, pSize);
      try
        GetPropList(ClsInfo, STRING_FILTER, pList);
        for i := 0 to pCount - 1 do
        begin
          name := pList^[I]^.Name;
          if (info.IndexOf(name) < 0) then
            info.Add(name);
        end;
      finally
        FreeMem(pList, pSize);
      end;
      info.Sorted := TRUE;
    finally
      MasterPropertyList.AddObject(Component.ClassName, info);
    end;
  end
  else
    info := TStringList(MasterPropertyList.Objects[idx]);
  Result := info;
end;

function TVA508AccessibilityManager.GetRootComponent(Component: TComponent;
  var PropertyName: String): TComponent;
var
  p: integer;
  CompName: string;
  root: TObject;

begin
  Root := Component;
  repeat
    p := pos(NAME_DELIM, PropertyName);
    if p > 0 then
    begin
      CompName := copy(PropertyName,1,p-1);
      delete(PropertyName,1,p);
      if IsPublishedProp(root, CompName) then
      begin
        root := GetObjectProp(root, CompName);
      end
      else
        root := nil;
    end;
  until (p=0) or (not assigned(root));
  if assigned(root) and (root is TComponent) and IsPublishedProp(root, PropertyName) then
    Result := TComponent(root)
  else
    Result := nil;
end;

function TVA508AccessibilityManager.GetUseDefault(
  Component: TWinControl): boolean;
begin
  Result := FData.FindItem(Component).UseDefault;
end;

function TVA508AccessibilityManager.IsPropertyNameValid(Component: TWinControl;
  PropertyName: String): boolean;
var
  list: TStrings;
begin
  if not assigned(Component) then
    Result := FALSE
  else
  begin
    list := GetPropertList(Component);
    Result := list.IndexOf(PropertyName) >= 0;
  end;
end;

procedure TVA508AccessibilityManager.Loaded;
var
  i: integer;
  data: TDFMData;
  component: TComponent;
  item: TVA508AccessibilityItem;
  
begin
  inherited;
  if assigned(FDFMData) then
  begin
    for i := 0 to FDFMData.Count-1 do
    begin
      data := TDFMData(FDFMData[i]);
      component := FindComponentOnForm(data.ComponentName);
      if assigned(component) and (component is TWinControl) then
      begin
        item := FData.FindItem(TWinControl(component));
        if data.LabelName <> '' then
        begin
          component := FindComponentOnForm(data.LabelName);
          if assigned(component) and (component is TLabel) then
            item.AccessLabel := TLabel(component);
        end;
        if data.PropertyName <> '' then
          item.AccessProperty := data.PropertyName;
        if data.Text <> '' then
          item.AccessText := data.Text;
        if data.Status = stsDefault then
          item.UseDefault := TRUE;
      end;
    end;
    FData.EnsureItemExists(TWinControl(Owner));
    FreeAndNil(FDFMData);
  end;
  if not (csDesigning in ComponentState) then
    Initialize;
end;

procedure TVA508AccessibilityManager.Notification(AComponent: TComponent;
  Operation: TOperation);

  procedure UpdateComponent(Component: TWinControl; Adding: boolean);
  var
    i: integer;
    Control : TWinControl;
    item: TVA508AccessibilityItem;
  begin
    if Adding then
      FData.EnsureItemExists(Component)
    else
    begin
      item := FData.FindItem(Component, FALSE);
      if assigned(item) then
        item.Free;
    end;
    if (csAcceptsControls in Component.ControlStyle) then
    begin
      for I := 0 to Component.ControlCount - 1 do
      begin
        if Component.Controls[I] is TWinControl then
        begin
          Control := TWinControl(Component.Controls[I]);
          if OwnerCheck(Control) then
            UpdateComponent(Control, Adding);
        end;
      end;
    end;
  end;

begin
  inherited Notification(AComponent, Operation);
  if (not assigned(AComponent)) or (not (AComponent is TWinControl)) or
          (csDestroying in ComponentState) then exit;
  if Operation = opInsert then
    UpdateComponent(TWinControl(AComponent), TRUE)
  else
    UpdateComponent(TWinControl(AComponent), FALSE);
end;

function TVA508AccessibilityManager.OwnerCheck(Component: TComponent): boolean;
var
  root: TComponent;
begin
  Result := false;
  root := component;
  while assigned(root) do
  begin
    if root = owner then
    begin
      Result := true;
      exit;
    end;
    root := root.Owner;
  end;
end;

procedure TVA508AccessibilityManager.DefineProperties(Filer: TFiler);
begin
  inherited DefineProperties(Filer);
  Filer.DefineProperty(VA508DFMDataPropertyName, ReadData, WriteData, TRUE);
end;

procedure TVA508AccessibilityManager.ReadData(Reader: TReader);
var
  data: TDFMData;
  line: string;
  name, value: string;
  idx: integer;

begin
  FData.Clear;
  if assigned(FDFMData) then
    FDFMData.Clear
  else
    FDFMData := TObjectList.Create;
  Reader.ReadListBegin;
  try
    while not Reader.EndOfList do
    begin
      Reader.ReadListBegin;
      try
        data := TDFMData.Create;
        FDFMData.Add(data);
        while not Reader.EndOfList do
        begin
          line := Reader.ReadString;
          idx := pos(EQU, line);
          if idx > 0 then
          begin
            name := copy(line,1,idx-1);
            value := copy(line, idx+EQU_LEN, MaxInt);
            if name = AccessDataComponentText then
              data.ComponentName := value
            else if name = AccessDataLabelText then
              data.LabelName := value
            else if name = AccessDataPropertyText then
              data.PropertyName := value
            else if name = AccessDataTextText then
              data.Text := value
            else if name = AccessDataStatusText then
              data.Status := TVA508AccessibilityStatus(GetEnumValue(
                                TypeInfo(TVA508AccessibilityStatus), value));
          end;
        end;
      finally
        Reader.ReadListEnd
      end;
    end;
  finally
    Reader.ReadListEnd;
  end;
end;

procedure TVA508AccessibilityManager.RefreshComponents;
begin
  Initialize;
end;

procedure TVA508AccessibilityManager.WriteData(Writer: TWriter);
var
  i: integer;
  item: TVA508AccessibilityItem;

begin
// ??????????????????
//  for i := FData.Count-1 downto 0 do
//  begin
//    if not assigned(FData.Items[i].Component) then
//      FData.Delete(i);
//  end;

  Writer.WriteListBegin;
  try
    for i := 0 to FData.Count - 1 do
    begin
      item := FData.Items[i];
      if assigned(item.Component) then
      begin
        item.UpdateStatus;
        Writer.WriteListBegin;
        try
          Writer.WriteString(AccessDataComponentText + EQU +
                              GetComponentName(item.Component));
          if assigned(item.AccessLabel) then
            Writer.WriteString(AccessDataLabelText + EQU +
                              GetComponentName(item.AccessLabel));
          if item.AccessProperty <> '' then
            Writer.WriteString(AccessDataPropertyText + EQU + item.AccessProperty);
          if item.AccessText <> '' then
            Writer.WriteString(AccessDataTextText + EQU + item.AccessText);
          Writer.WriteString(AccessDataStatusText + EQU +
              GetEnumName(TypeInfo(TVA508AccessibilityStatus), ord(item.Status)));
        finally
          Writer.WriteListEnd;
        end;
      end;
    end;
  finally
    Writer.WriteListEnd;
  end;
end;

type
  AccessComponent = class(TWinControl);

function TVA508AccessibilityManager.ScreenReaderInquiry(
  Component: TWinControl): string;
var
  item: TVA508AccessibilityItem;
  prop: string;
  comp: TComponent;
  DynaComp: IVADynamicProperty;

begin
  Result := '';
  item := FData.FindItem(Component);

  if item.UseDefault then
  begin
    if AccessComponent(Component).QueryInterface(IVADynamicProperty,DynaComp) = S_OK then
    begin
      try
        if DynaComp.SupportsDynamicProperty(DynaPropAccesibilityCaption) then
          Result := DynaComp.GetDynamicProperty(DynaPropAccesibilityCaption);
      finally
        DynaComp := nil;
      end;
    end;
  end
  else
  begin
    if assigned(item.AccessLabel) then
      Result := item.AccessLabel.Caption
    else if item.AccessText <> '' then
      Result := item.AccessText
    else
    begin
      prop := item.AccessProperty;
      if prop <> '' then
      begin
        comp := GetRootComponent(Component, prop);
        if assigned(comp) then
          Result := GetPropValue(comp, prop);
      end;
    end;
  end;
end;

procedure TVA508AccessibilityManager.SetAccessLabel(Component: TWinControl;
  const Value: TLabel);
begin
  FData.FindItem(Component).AccessLabel := Value;
end;

procedure TVA508AccessibilityManager.SetAccessProperty(Component: TWinControl;
  const Value: String);
begin
  FData.FindItem(Component).AccessProperty := Value;
end;

procedure TVA508AccessibilityManager.SetAccessText(Component: TWinControl;
  const Value: String);
begin
  FData.FindItem(Component).AccessText := Value;
end;

procedure TVA508AccessibilityManager.SetComponentManager(Component: TWinControl;
  const Value: TVA508ComponentManager);
begin
  FData.FindItem(Component).ComponentManager := Value;
end;

procedure TVA508AccessibilityManager.SetUseDefault(Component: TWinControl;
  const Value: boolean);
begin
  FData.FindItem(Component).UseDefault := Value;
end;

procedure TVA508AccessibilityManager.Initialize;
var
  list: TList;
  i, idx: integer;
  control: TWinControl;
  item: TVA508AccessibilityItem;

  procedure Update(Component: TWinControl);
  var
    i: integer;
  begin
    if (not assigned(Component.Parent)) or (csAcceptsControls in Component.Parent.ControlStyle) then
      list.add(Component);
    for I := 0 to Component.ControlCount - 1 do
    begin
      if Component.Controls[I] is TWinControl then
      begin
        Control := TWinControl(Component.Controls[I]);
        if (not assigned(Control.Owner)) or OwnerCheck(Control) then
          Update(Control);
      end;
    end;
  end;

begin
  list := TList.Create;
  try
    if (Owner is TWinControl) and ([csLoading, csDesignInstance] * Owner.ComponentState = []) then
      Update(TWinControl(Owner));
    for I := FData.Count - 1 downto 0 do
    begin
      item := FData[i];

      if assigned(item.Component) then
      begin
        idx := list.IndexOf(item.Component);
        if idx < 0 then
          item.Free
        else
          list.delete(idx);
      end
      else
        item.free;
    end;
    for I := 0 to List.Count - 1 do
    begin
      FData.EnsureItemExists(TWinControl(list[i]));
    end;
  finally
    list.free;
  end;
end;

{ Registration }
type
  TAlternateHandleData = class
    ComponentClass: TWinControlClass;
    GetHandle: TVA508AlternateHandleFunc;
  end;

procedure RegisterAlternateHandleComponent(ComponentClass: TWinControlClass;
                                           AlternateHandleFunc: TVA508AlternateHandleFunc);
var
  data: TAlternateHandleData;
  i: integer;
begin
  if not ScreenReaderSystemActive then exit;
  if not assigned(AltHandleClasses) then
    AltHandleClasses := TObjectList.Create
  else
  begin
    for i := 0 to AltHandleClasses.Count - 1 do
    begin
      data := TAlternateHandleData(AltHandleClasses[i]);
      if ComponentClass = data.ComponentClass then exit;
    end;
  end;
  data := TAlternateHandleData.Create;
  data.ComponentClass := ComponentClass;
  data.GetHandle := AlternateHandleFunc;
  AltHandleClasses.Add(data);
end;

procedure RegisterComplexComponentManager(Manager: TVA508ComplexComponentManager);
var
  data: TVA508ComplexComponentManager;
  i: integer;
begin
  if ScreenReaderSystemActive then
  begin
    if not assigned(ComplexClasses) then
      ComplexClasses := TObjectList.Create
    else
    begin
      for i := 0 to ComplexClasses.Count - 1 do
      begin
        data := TVA508ComplexComponentManager(ComplexClasses[i]);
        if data.ComponentClass = Manager.ComponentClass then
        begin
          Manager.Free;
          exit;
        end;
      end;
    end;
    ComplexClasses.Add(Manager);
  end
  else
    Manager.Free;
end;

procedure RegisterManagedComponentClass(Manager: TVA508ManagedComponentClass);
var
  data: TVA508ManagedComponentClass;
  i: integer;
begin
  if ScreenReaderSystemActive then
  begin
    if not assigned(ManagedClasses) then
      ManagedClasses := TObjectList.Create
    else
    begin
      for i := 0 to ManagedClasses.Count - 1 do
      begin
        data := TVA508ManagedComponentClass(ManagedClasses[i]);
        if Manager.ComponentClassType = data.ComponentClassType then
        begin
          if Manager <> data then
            Manager.Free;
          exit;
        end;
      end;
    end;
    ManagedClasses.Add(Manager);
  end
  else
    Manager.Free;
end;

function FindMSAAQueryData(MSAAClass: TWinControlClass): TMSAAData;
var
  i: integer;
begin
  Result := nil;
  if not assigned(MSAAQueryClasses) then exit;
  for i := 0 to MSAAQueryClasses.Count - 1 do
  begin
    Result := TMSAAData(MSAAQueryClasses[i]);
    if MSAAClass.InheritsFrom(Result.MSAAClass) then exit;
  end;
  Result := nil;
end;

procedure RegisterMSAAProc(MSAAClass: TWinControlClass;
          Proc: TVA508QueryProc; ListProc: TVA508ListQueryProc);
var
  Data: TMSAAData;
begin
  if not assigned(MSAAQueryClasses) then
    MSAAQueryClasses := TObjectList.Create;
  Data := FindMSAAQueryData(MSAAClass);
  if not assigned(Data) then
  begin
    Data := TMSAAData.Create;
    Data.MSAAClass := MSAAClass;
    Data.Proc := Proc;
    Data.ListProc := ListProc;
    MSAAQueryClasses.Add(Data);
  end;
end;

procedure RegisterMSAAQueryClassProc(MSAAClass: TWinControlClass; Proc: TVA508QueryProc);
begin
  RegisterMSAAProc(MSAAClass, Proc, nil);
end;

procedure RegisterMSAAQueryListClassProc(MSAAClass: TWinControlClass; Proc: TVA508ListQueryProc);
begin
  RegisterMSAAProc(MSAAClass, nil, Proc);
end;

{ TVAGlobalComponentRegistry }

procedure TVAGlobalComponentRegistry.CheckForChangeEvent;
var
  Helper: TComponentHelper;
  NewCaption: string;
  NewState: string;

  NewItem: TObject;
  SendData: boolean;
  CheckState: boolean;
  DataResult: LongInt;
  DataStatus: LongInt;
  NewItemInstructions: string;
  Temp: string;

  Caption: PChar;
  Value: PChar;
  Data: PChar;
  ControlType: PChar;
  State: PChar;
  Instructions: PChar;
  ItemInstructions: PChar;

  function HandleStillValid: boolean;
  begin
    Result := IsWindow(FComponentData.Handle) and IsWindowVisible(FComponentData.Handle);
  end;

  function NoChangeNeeded: boolean;
  begin
    Result := TRUE;
    if not assigned(SRComponentData) then exit;
    if not assigned(SRConfigChangePending) then exit;
    if FComponentData.Handle = 0 then exit;
    Helper := GetComponentHelper(FComponentData.Handle);
    if not assigned(Helper) then exit;
    Helper.InitializeComponentManager;
    if Helper.StandardComponent then exit;
    if SRConfigChangePending then exit;
    Result := FALSE;
  end;

  procedure Init;
  begin
    DataResult := DATA_NONE;
    DataStatus := DATA_NONE;
    Caption := nil;
    Value := nil;
    Data := nil;
    ControlType := nil;
    State := nil;
    Instructions := nil;
    ItemInstructions := nil;
    CheckState := TRUE;
  end;

  procedure ProcessCaptionChange;
  begin
    if FComponentData.CaptionQueried and Helper.ManageCaption then
    begin
      NewCaption := Helper.GetCaption(DataResult);
      if (FComponentData.Caption <> NewCaption) then
      begin
        FComponentData.Caption := NewCaption;
        if ((DataResult and DATA_CAPTION) <> 0) then
        begin
          DataStatus := DataStatus OR DATA_CAPTION;
          Caption := PChar(NewCaption);
        end;
      end;
    end;
  end;

  procedure ProcessItemChange;
  var
    TempValue: string;
  begin
    if FComponentData.ValueQueried and Helper.MonitorForItemChange then
    begin
      NewItem := Helper.GetItem;
      if (FComponentData.Item <> NewItem) then
      begin
        FComponentData.Item := NewItem;
        CheckState := FALSE;
        SendData := FALSE;

        if Helper.ManageValue then
        begin
          Value := PChar(Helper.GetValue(DataResult));
          if (DataResult AND DATA_VALUE) <> 0 then
          begin
            SendData := TRUE;
            DataStatus := DataStatus OR DATA_VALUE;
          end;
        end;

        if Helper.ManageData then
        begin
          if Helper.ManageValue then
            TempValue := Value
          else
            TempValue := '';
          Data := PChar(Helper.GetData(DataResult, Value));
          if (DataResult AND DATA_DATA) <> 0 then
          begin
            SendData := TRUE;
            DataStatus := DataStatus OR DATA_DATA;
          end;
        end;

        if FComponentData.StateQueried and Helper.MonitorForStateChange then
        begin
          NewState := Helper.GetState(DataResult);
          if FComponentData.State <> NewState then
            FComponentData.State := NewState;
          if (DataResult AND DATA_STATE) <> 0 then
          begin
            State := PChar(NewState);
            SendData := TRUE;
            DataStatus := DataStatus OR DATA_STATE;
            if FComponentData.ItemInstrQueried and Helper.ManageItemInstructions then
            begin
              NewItemInstructions := Helper.GetItemInstructions(DataResult);
              if NewItemInstructions <> '' then
              begin
                temp := IIDelim + NewItemInstructions + IIDelim;
                if pos(temp, FComponentData.ItemInstructions) < 1  then
                begin
                  FComponentData.ItemInstructions := FComponentData.ItemInstructions + NewItemInstructions + IIDelim;
                  ItemInstructions := PChar(NewItemInstructions);
                  if (DataResult AND DATA_ITEM_INSTRUCTIONS) <> 0 then
                    DataStatus := DataStatus OR DATA_ITEM_INSTRUCTIONS;
                end;
              end;
            end;
          end;
        end;
        if SendData then
          DataStatus := DataStatus OR DATA_ITEM_CHANGED;
      end;    
    end;
  end;

  procedure ProcessStateChange;
  begin
    if CheckState and FComponentData.StateQueried and Helper.MonitorForStateChange then
    begin
      NewState := Helper.GetState(DataResult);
      if FComponentData.State <> NewState then
      begin
        FComponentData.State := NewState;
        if (DataResult AND DATA_STATE) <> 0 then
        begin
          State := PChar(NewState);
          DataStatus := DataStatus OR DATA_STATE;
        end;
      end;
    end;
  end;

  procedure AddControlType;
  begin
    if (DataStatus <> DATA_NONE) and Helper.ManageComponentName then
    begin
      ControlType := PChar(Helper.GetComponentName(DataResult));
      if (DataResult AND DATA_CONTROL_TYPE) <> 0 then
      begin
        DataStatus := DataStatus OR DATA_CONTROL_TYPE;
      end;
    end;
  end;

  procedure SendChangeData;
  begin
    if (DataStatus <> DATA_NONE) then
    begin
      DataStatus := DataStatus OR DATA_CHANGE_EVENT;
      SRComponentData(FComponentData.Handle, DataStatus, Caption, Value, Data, ControlType,
                      State, Instructions, ItemInstructions);
    end;
  end;

begin
  if NoChangeNeeded then
  begin
    exit;
  end;
  // HandleStillValid needed because reminders destroy check boxes from underneath us
  if HandleStillValid then Init;
  if HandleStillValid then ProcessCaptionChange;
  if HandleStillValid then ProcessItemChange;
  if HandleStillValid then ProcessStateChange;
  if HandleStillValid then AddControlType;
  if HandleStillValid then SendChangeData;
end;


procedure TVAGlobalComponentRegistry.ComponentDataNeededEvent(const WindowHandle: HWND;
    var DataStatus: LongInt; var Caption: PChar; var Value: PChar; var Data: PChar;
    var ControlType: PChar; var State: PChar; var Instructions: PChar; var ItemInstructions: PChar);
var
  DataResult: LongInt;
  UseCaption: boolean;
  UseValue: boolean;
  UseControlType: boolean;
  UseState: boolean;
  UseInstructions: boolean;
  UseItemInstructions: boolean;
  NewCaption: string;
  NewState: string;
  NewItemInstructions: string;
  NewValue: string;
  NewData: string;
  NewInstructions: string;
  NewControlType: string;
  Component: TWinControl;
  HelperInvalid: boolean;
  Done: boolean;
  temp: string;

  function HelperValid: boolean;
  begin
    if HelperInvalid then
    begin
      Result := FALSE;
      exit;
    end;
    try
      Result := assigned(FCurrentHelper) and
                assigned(FCurrentHelper.FComponent) and
                IsWindow(FCurrentHelper.FComponent.Handle) and
                IsWindowVisible(FCurrentHelper.FComponent.Handle);
    except
      Result := FALSE;
    end;
    if not Result then
    begin
      HelperInvalid := TRUE;
    end;
  end;
  
  procedure UpdateComponentData;
  begin
    if (FComponentData.Handle = WindowHandle) then
    begin
      if UseCaption then
      begin
        FComponentData.CaptionQueried := TRUE;
        FComponentData.Caption := NewCaption;
      end;
      if UseValue then
      begin
        FComponentData.ValueQueried := TRUE;
        if FCurrentHelper.MonitorForItemChange and HelperValid then
          FComponentData.Item := FCurrentHelper.GetItem;
      end;
      if UseState then
      begin
        FComponentData.StateQueried := TRUE;
        FComponentData.State := NewState;
      end;
      if UseItemInstructions then
      begin
        FComponentData.ItemInstrQueried := TRUE;
        FComponentData.ItemInstructions := IIDelim + NewItemInstructions + IIDelim;
      end;
    end;
  end;

  procedure InitializeVars;
  begin
    DataResult          := DATA_NONE;
    UseCaption          := ((DataStatus and DATA_CAPTION) <> 0);
    UseValue            := ((DataStatus and DATA_VALUE) <> 0);
    UseControlType      := ((DataStatus and DATA_CONTROL_TYPE) <> 0);
    UseState            := ((DataStatus and DATA_STATE) <> 0);
    UseInstructions     := ((DataStatus and DATA_INSTRUCTIONS) <> 0);
    UseItemInstructions := ((DataStatus and DATA_ITEM_INSTRUCTIONS) <> 0);

    NewCaption := '';
    NewState := '';
    NewItemInstructions := '';

    if HelperValid then FCurrentHelper.InitializeComponentManager;
  end;

  procedure GetDataValues;
  begin
    if UseCaption and HelperValid then
    begin
      NewCaption := FCurrentHelper.GetCaption(DataResult);
      Caption := PChar(NewCaption);
    end;

    if UseValue and HelperValid then
    begin
    //PChars are pointers - must point to string - if point to function thier values change unpredictably
      NewValue := FCurrentHelper.GetValue(DataResult);
      Value := PChar(NewValue);
      NewData := FCurrentHelper.GetData(DataResult, NewValue);
      Data := PChar(NewData);
    end;

    if UseControlType and HelperValid then
    begin
      NewControlType := FCurrentHelper.GetComponentName(DataResult);
      ControlType := PChar(NewControlType);
    end;

    if UseState and HelperValid then
    begin
      NewState := FCurrentHelper.GetState(DataResult);
      State := PChar(NewState);
    end;

    if UseInstructions and HelperValid then
    begin
      NewInstructions := FCurrentHelper.GetInstructions(DataResult);
      Instructions := PChar(NewInstructions);
    end;

    if UseItemInstructions and HelperValid then
    begin
      NewItemInstructions := FCurrentHelper.GetItemInstructions(DataResult);
      ItemInstructions := PChar(NewItemInstructions);
    end;
  end;

begin
  if FDestroying then exit;
  if (FComponentData.Handle <> WindowHandle) then
  begin
    FComponentData := NewComponentData;
    FComponentData.Handle := WindowHandle;
  end;

  HelperInvalid := FALSE;
  FCurrentHelper := GetComponentHelper(WindowHandle);
  if not assigned(FCurrentHelper) then
    DataResult := DATA_ERROR
  else
  begin
    if HelperValid then
    begin
      try
        repeat
          Done := TRUE;
          if HelperValid then
            Component := FCurrentHelper.FComponent
          else
            Component := nil;
          if HelperValid then InitializeVars;
          if HelperValid then temp := FCurrentHelper.Component.ClassName;
          if HelperValid then GetDataValues;
          if HelperValid then UpdateComponentData;
          if (not assigned(FCurrentHelper)) and assigned(Component) then
          begin
            try
              FCurrentHelper := GetComponentHelper(Component.Handle);
              Done := FALSE;
              HelperInvalid := FALSE;
            except
            end;
          end;
        until Done;
      finally
        FCurrentHelper := nil;
      end;
      if HelperInvalid and (DataResult = DATA_NONE) then
        DataResult := DATA_ERROR;
    end
    else
    begin
      FCurrentHelper := nil;
      DataResult := DATA_ERROR;
    end;
  end;
  DataStatus := DataResult;
end;

var
  CanAssignFocus: boolean = TRUE;

var
  CanCheckEvent: boolean = TRUE;

function GetMessageHookProc(Code: Integer; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall;
var
  pMessage: PMsg;
  msg: UINT;

begin
  if CanCheckEvent then
  begin
    CanCheckEvent := FALSE;
    try
      if TVAGlobalComponentRegistry.FActive and (code >= 0) then
      begin
        pMessage := pointer(lParam);
        msg := pMessage^.message and $ffff;
        case msg of
          WM_KEYFIRST .. WM_KEYLAST,
          (WM_MOUSEFIRST + 1) .. WM_MOUSELAST: // WM_MOUSEFIRST = WM_MOUSEMOVE
          GlobalRegistry.CheckForChangeEvent;
        end;
      end;
    finally
      CanCheckEvent := TRUE;
    end;
  end;
  Result := CallNextHookEx(TVAGlobalComponentRegistry.FGetMsgHookHandle, Code, wParam, lParam);
end;

constructor TVAGlobalComponentRegistry.Create;
begin
  FPendingFieldObjects := TStringList.Create;
  FComponentRegistry := TStringList.Create;
  FComponentRegistry.Duplicates := dupAccept;
  FComponentRegistry.Sorted := TRUE;
  FHandlesXREF := TStringList.Create;
  FHandlesXREF.Duplicates := dupAccept;
  FHandlesXREF.Sorted := TRUE;
  FHandlesPending := TStringList.Create;
  FPendingRecheckTimer := TTimer.Create(nil);
  FPendingRecheckTimer.Enabled := FALSE;
  FPendingRecheckTimer.OnTimer := TimerEvent;
  FPendingRecheckTimer.Interval := 500;
  FComponentData := NewComponentData;
  FGetMsgHookHandle := SetWindowsHookEx(WH_GETMESSAGE, GetMessageHookProc, 0, GetCurrentThreadID);
  TVA508RegistrationScreenReader(GetScreenReader).
              AddComponentDataNeededEventHandler(ComponentDataNeededEvent);
  FActive := TRUE;
end;

destructor TVAGlobalComponentRegistry.Destroy;
begin
  FDestroying := TRUE;
  FActive := FALSE;
  TVA508RegistrationScreenReader(GetScreenReader).RemoveComponentDataNeededEventHandler(ComponentDataNeededEvent);
  UnhookWindowsHookEx(FGetMsgHookHandle);
  FreeAndNil(FPendingRecheckTimer);
  FreeAndNil(FHandlesPending);
  FreeAndNil(FHandlesXREF);
  FreeAndNil(FPendingFieldObjects);
  FreeAndNilTStringsAndObjects(FComponentRegistry);
  inherited;
end;

function TVAGlobalComponentRegistry.GetCompKey(Component: TWinControl): String;
begin
  Result := FastIntToHex(Integer(Component));
end;

function TVAGlobalComponentRegistry.GetComponentHandle(Component: TWinControl): Hwnd;
var
  i: integer;
  UseDefault: boolean;
  data: TAlternateHandleData;
  ok: boolean;
begin
  Result := 0;
  ok := Component.Visible;
  if ok then
  begin
    ok := Component is TCustomForm;
    if not ok then
    begin
      ok := assigned(Component.parent);
      if ok then
        ok := Component.parent.Visible;
    end;
  end;
  if ok then
  begin
    UseDefault := TRUE;
    if assigned(AltHandleClasses) then
    begin
      for i := 0 to AltHandleClasses.Count-1 do
      begin
        data := TAlternateHandleData(AltHandleClasses[i]);
        if Component.InheritsFrom(data.ComponentClass) then
        begin
          UseDefault := FALSE;
          Result := data.GetHandle(Component);
        end;
      end;
    end;
    if UseDefault then
    begin
      try
        Result := Component.Handle
      except
        Result := 0;
      end;
    end;
  end;
end;

function TVAGlobalComponentRegistry.GetFieldObject(Component: TWinControl): TVA508ComponentAccessibility;
var
  idx: integer;
  compKey: string;
begin
  compKey := GetCompKey(component);
  idx := FComponentRegistry.IndexOf(compkey);
  if idx < 0 then
  begin
    idx := FPendingFieldObjects.IndexOf(compKey);
    if idx < 0 then
      Result := nil
    else
      Result := TVA508ComponentAccessibility(FPendingFieldObjects.Objects[idx]);
  end
  else
    Result := TComponentHelper(FComponentRegistry.Objects[idx]).FieldObject;
end;

function TVAGlobalComponentRegistry.GetComponentHelper(WindowHandle: HWND): TComponentHelper;
var
  key: string;
  idx: integer;
  Recheck: boolean;
begin
  Result := nil;
  if IsWindow(WindowHandle) and IsWindowVisible(WindowHandle) then
  begin
    key := FastIntToHex(WindowHandle);
    idx := FHandlesXREF.IndexOf(key);
    if idx < 0 then
    begin
      UpdateHandles(WindowHandle, Recheck);
      if Recheck then
        idx := FHandlesXREF.IndexOf(key);
    end;
    if idx >= 0 then
    begin
      Result := TComponentHelper(FHandlesXREF.Objects[idx]);
    end;
  end;
end;

function TVAGlobalComponentRegistry.HasHandle(Component: TWinControl;
  var HandleKey: String): boolean;
begin
  Result := FALSE;
  HandleKey := '';
  if FDestroying then exit;
  try
    if Component.Visible and ((Component.Parent <> nil) or (Component is TCustomForm)) then
      HandleKey := FastIntToHex(GetComponentHandle(Component));
  except
    HandleKey := '';
  end;
  Result := (HandleKey <> '') and (HandleKey <> '00000000');
end;

procedure TVAGlobalComponentRegistry.RegisterFieldObject(
  Component: TWinControl; FieldObject: TVA508ComponentAccessibility;
  Adding: boolean);
var
  idx: integer;
  compKey: string;
  Helper: TComponentHelper;

begin
  if FDestroying or (not assigned(Component)) then exit;
  compKey := GetCompKey(component);
  idx := FComponentRegistry.IndexOf(compkey);
  if idx < 0 then
  begin
    if Adding then
    begin
      if FPendingFieldObjects.IndexOf(CompKey) < 0 then
        FPendingFieldObjects.AddObject(compKey, FieldObject)
    end
    else
    begin
      idx := FPendingFieldObjects.IndexOf(CompKey);
      if idx >= 0 then
        FPendingFieldObjects.Delete(idx);
    end;
  end
  else
  begin
    Helper := TComponentHelper(FComponentRegistry.Objects[idx]);
    if Adding then
      Helper.FieldObject := FieldObject
    else
      Helper.FieldObject := nil;
  end;
end;

procedure TVAGlobalComponentRegistry.RegisterMSAA(Component: TWinControl);
var
  Data: TMSAAData;
begin
  if Component.InheritsFrom(TWinControl) then
  begin
    Data := FindMSAAQueryData(TWinControlClass(Component.ClassType));
    if assigned(Data) then
    begin
      if assigned(data.Proc) then
        RegisterMSAAComponentQueryProc(Component, Data.Proc)
      else
        RegisterMSAAComponentListQueryProc(Component, Data.ListProc)
    end;
  end;
end;

procedure TVAGlobalComponentRegistry.RegisterComponent(
      component: TWinControl; Manager: TVA508AccessibilityManager);
var
  Helper: TComponentHelper;
  compKey, handleKey: string;

  procedure CheckManagedClasses;
  var
    cls: TClass;
    pass: integer;
    i: integer;
    mData: TVA508ManagedComponentClass;
    found, ok: boolean;
  begin
    if assigned(ManagedClasses) then
    begin
      cls := Component.ClassType;
      found := FALSE;
      for pass := 0 to 1 do
      begin
        for i := 0 to ManagedClasses.Count - 1 do
        begin
          mData := TVA508ManagedComponentClass(ManagedClasses[i]);
          if mData.ManageDescendentClasses then
          begin
            if (pass = 1) then
              ok := cls.InheritsFrom(mData.ComponentClassType)
            else
              ok := false;
          end
          else
          begin
            if (pass = 0) then
              ok := (mData.ComponentClassType = cls)
            else
              ok := false;
          end;
          if ok then
          begin
            Helper.ManagedClassData := mData;
            found := TRUE;
            break;
          end;
        end;
        if found then
          break;
      end;
    end;
  end;

  procedure CheckComplexClasses;
  var
    cls: TClass;
    i: integer;
    mgr: TVA508ComplexComponentManager;
  begin
    if assigned(ComplexClasses) then
    begin
      cls := Component.ClassType;
      for i := 0 to ComplexClasses.Count - 1 do
      begin
        mgr := TVA508ComplexComponentManager(ComplexClasses[i]);
        if cls.InheritsFrom(mgr.ComponentClass) then
        begin
          Helper.ComplexManager := mgr;
          mgr.Refresh(Component, Manager);
          break;
        end;
      end;
    end;
  end;

  procedure CreateHelper;  //TVA508ComplexComponentManager(ComplexClasses[i]);
  var
    idx: integer;
  begin
    Helper := TComponentHelper.Create;
    Helper.Component := Component;
    Helper.Manager := Manager;
    Helper.ManagedClassData := nil;
    CheckComplexClasses;
    CheckManagedClasses;
    idx := FPendingFieldObjects.IndexOf(compKey);
    if idx >= 0 then
    begin
      Helper.FieldObject := TVA508ComponentAccessibility(FPendingFieldObjects.Objects[idx]);
      FPendingFieldObjects.Delete(idx);
    end;
  end;

  procedure RegisterComponent;
  begin
    compKey := GetCompKey(component);
    if FComponentRegistry.IndexOf(compkey) < 0 then
    begin
      CreateHelper;
      FComponentRegistry.AddObject(compKey, Helper);
      if HasHandle(Component, HandleKey) then
      begin
        Helper.HandleKey := HandleKey;
        FHandlesXREF.AddObject(HandleKey, Helper);
        RegisterMSAA(Component);
      end
      else
      begin
        FHandlesPending.AddObject(compKey, Helper);
        if not FPendingRecheckTimer.Enabled then
          FPendingRecheckTimer.Enabled := TRUE;
      end;
    end;
  end;

begin
  if FDestroying or (not assigned(Component)) then exit;
  RegisterComponent;
end;

procedure TVAGlobalComponentRegistry.TimerEvent(Sender: TObject);
var
  idx: integer;
  Helper: TComponentHelper;
  handleKey: string;

  function SkipCheck: boolean;
  begin
    Result := FDestroying or FUnregisteringComponent;
  end;

begin
  if SkipCheck or FCheckingPendingList then exit;
  FCheckingPendingList := TRUE;
  try
    idx := FHandlesPending.Count-1;
    while (idx >= 0) and (not SkipCheck) do
    begin
      Helper := TComponentHelper(FHandlesPending.Objects[idx]);
      if HasHandle(Helper.Component, handleKey) then
      begin
        Helper.HandleKey := handleKey;
        FHandlesXREF.AddObject(handleKey, Helper);
        FHandlesPending.Delete(idx);
        RegisterMSAA(Helper.Component);
      end;
      dec(idx);
    end;
    if FHandlesPending.Count = 0 then
      FPendingRecheckTimer.Enabled := FALSE;
  finally
    FCheckingPendingList := FALSE;
  end;
end;

procedure TVAGlobalComponentRegistry.UnregisterComponent(
  component: TWinControl);
var
  idx: integer;
  compKey, handleKey: string;
  Helper: TComponentHelper;
begin
  if FDestroying or (not assigned(component)) then exit;
  FUnregisteringComponent := TRUE;
  try
    compKey := GetCompKey(Component);
    idx := FComponentRegistry.IndexOf(compkey);
    if idx >= 0 then
    begin
      Helper := TComponentHelper(FComponentRegistry.Objects[idx]);
      handleKey := Helper.HandleKey;
      FComponentRegistry.Delete(idx);
      idx := FHandlesXREF.IndexOf(handleKey);
      if idx >= 0 then
        FHandlesXREF.Delete(idx);
      idx := FHandlesPending.IndexOf(compKey);
      if idx >= 0 then
        FHandlesPending.Delete(idx);
      Helper.Free;
      if assigned(Component) then
        UnregisterMSAA(Component);
    end;
  finally
    FUnregisteringComponent := FALSE;
  end;
end;


procedure TVAGlobalComponentRegistry.UnregisterMSAA(Component: TWinControl);
var
  Data: TMSAAData;
begin
  if Component.InheritsFrom(TWinControl) then
  begin
    Data := FindMSAAQueryData(TWinControlClass(Component.ClassType));
    if assigned(Data) then
    begin
      if assigned(Data.Proc) then
        UnregisterMSAAComponentQueryProc(Component, Data.Proc)
      else
        UnregisterMSAAComponentListQueryProc(Component, Data.ListProc);
    end;
  end;
end;

procedure TVAGlobalComponentRegistry.UpdateHandles(WindowHandle: HWnd; var HandlesModified: boolean);
var
  Handle: Hwnd;
  TimerRunning: boolean;
  HandleIndex: integer;

  procedure UpdateHandle(index: integer);
  var
    Helper: TComponentHelper;
    StatedHandle, TrueHandle: HWnd;
    key : string;
    idx: integer;

  begin
    StatedHandle := FastHexToInt(FHandlesXREF[index]);
    Helper := TComponentHelper(FHandlesXREF.Objects[index]);
    if assigned(Helper) and assigned(Helper.Component) then
    begin
      TrueHandle := GetComponentHandle(Helper.Component);
      if TrueHandle <> 0 then
      begin
        if StatedHandle <> TrueHandle then
        begin
          key := FastIntToHex(TrueHandle);
          Helper.HandleKey := key;
          HandlesModified := TRUE;
          if FHandlesXREF.Sorted then
          begin
            FHandlesXREF.Delete(index);
            FHandlesXREF.AddObject(key, Helper);
          end
          else
            FHandlesXREF[index] := key;
        end;
      end
      else
      begin
        Helper.HandleKey := '';
        FHandlesPending.AddObject(GetCompKey(Helper.component), Helper);
        FHandlesXREF.Delete(index);
        TimerRunning := TRUE;
      end;
    end
    else
    begin
      FHandlesXREF.Delete(index);
      if assigned(Helper) then
      begin
        key := GetCompKey(Helper.component);
        idx := FComponentRegistry.IndexOf(key);
        if idx >= 0 then
          FComponentRegistry.delete(idx);
        Helper.Free;
      end;
    end;
  end;

  function FindRootHandle(WindowHandle: HWnd; var idx: integer): Hwnd;
  var
    done: boolean;
    key: string;

  begin
    Result := WindowHandle;
    done := FALSE;
    repeat
      key := FastIntToHex(Result);
      idx := FHandlesXREF.IndexOf(key);
      if idx < 0 then
      begin
        Result := Windows.GetAncestor(Result, GA_PARENT);
        if Result = 0 then
          done := TRUE;
      end
      else
        done := TRUE;
    until done;
  end;

  procedure UpdateAllHandles;
  var
    i: integer;
  begin
    FHandlesXREF.Sorted := FALSE;
    try
      for I := FHandlesXREF.Count - 1 downto 0 do
      begin
        UpdateHandle(i);
      end;
    finally
      FHandlesXREF.Sorted := TRUE;
    end;  
  end;

  procedure UpdateChildrenHandles(idx: integer);
  var
    i, objIdx, hexidx: integer;
    Helper, child: TComponentHelper;
    objKey, key: string;
    ctrl: TControl;
  begin
    Helper := TComponentHelper(FHandlesXREF.Objects[idx]);
    if assigned(Helper) then
    begin
      if assigned(Helper.ComplexManager) then
        Helper.ComplexManager.Refresh(Helper.Component, Helper.Manager);
      for i := 0 to Helper.component.ControlCount-1 do
      begin
        ctrl := Helper.component.Controls[i];
        if assigned(ctrl) and (ctrl is TWinControl) then
        begin
          objKey := GetCompKey(TWinControl(ctrl));
          objIdx := FComponentRegistry.IndexOf(objKey);
          if objidx >= 0 then
          begin
            child := TComponentHelper(FComponentRegistry.Objects[objidx]);
            if assigned(child) then
            begin
              key := child.HandleKey;
              hexidx := FHandlesXREF.IndexOf(key);
              if hexidx >= 0 then
              begin
                UpdateHandle(hexidx);
                if key <> child.HandleKey then
                begin
                  hexidx := FHandlesXREF.IndexOf(child.HandleKey);
                  if hexidx >= 0 then
                  begin
                    UpdateChildrenHandles(hexidx);
                  end;
                end;
              end;
            end;
          end
        end;
      end;
    end;
  end;

begin
  TimerRunning := FPendingRecheckTimer.Enabled;
  FPendingRecheckTimer.Enabled := FALSE;
  HandlesModified := FALSE;
  try
    Handle := FindRootHandle(WindowHandle, HandleIndex);
    if Handle = 0 then
      UpdateAllHandles
    else
      UpdateChildrenHandles(HandleIndex);
  finally
    FPendingRecheckTimer.Enabled := TimerRunning;
  end;
end;

{ TVA508ComponentManager }

constructor TVA508ComponentManager.Create(ManagedTypes: TManagedTypes);
begin
  FManagedTypes := ManagedTypes;
end;

function TVA508ComponentManager.GetCaption(Component: TWinControl): string;
begin
  Result := '';
end;

function TVA508ComponentManager.GetComponentName(
  Component: TWinControl): string;
begin
  Result := '';
end;

function TVA508ComponentManager.GetData(Component: TWinControl; Value: string): string;
begin
  Result := '';
end;

function TVA508ComponentManager.GetInstructions(Component: TWinControl): string;
begin
  Result := '';
end;

function TVA508ComponentManager.GetItem(Component: TWinControl): TObject;
begin
  Result := nil;
end;

function TVA508ComponentManager.GetItemInstructions(
  Component: TWinControl): string;
begin
  Result := '';
end;

function TVA508ComponentManager.GetState(Component: TWinControl): string;
begin
  Result := '';
end;

function TVA508ComponentManager.GetValue(Component: TWinControl): string;
begin
  Result := '';
end;

function TVA508ComponentManager.ManageCaption(Component: TWinControl): boolean;
begin
  Result := mtCaption in FManagedTypes;
end;

function TVA508ComponentManager.ManageComponentName(
  Component: TWinControl): boolean;
begin
  Result := mtComponentName in FManagedTypes;
end;

function TVA508ComponentManager.ManageData(Component: TWinControl): boolean;
begin
  Result := mtData in FManagedTypes;
end;

function TVA508ComponentManager.ManageInstructions(
  Component: TWinControl): boolean;
begin
  Result := mtInstructions in FManagedTypes;
end;

function TVA508ComponentManager.ManageItemInstructions(
  Component: TWinControl): boolean;
begin
  Result := mtItemInstructions in FManagedTypes;
end;

function TVA508ComponentManager.ManageState(Component: TWinControl): boolean;
begin
  Result := mtState in FManagedTypes;
end;

function TVA508ComponentManager.ManageValue(Component: TWinControl): boolean;
begin
  Result := mtValue in FManagedTypes;
end;

function TVA508ComponentManager.MonitorForItemChange(
  Component: TWinControl): boolean;
begin
  Result := mtItemChange in FManagedTypes;
end;

function TVA508ComponentManager.MonitorForStateChange(
  Component: TWinControl): boolean;
begin
  Result := mtStateChange in FManagedTypes;
end;

function TVA508ComponentManager.Redirect(Component: TWinControl;
  var ManagedType: TManagedType): TWinControl;
begin
  Result := nil;
  ManagedType := mtNone;
end;

function TVA508ComponentManager.RedirectsComponent(Component: TWinControl): boolean;
begin
  Result := mtComponentRedirect in FManagedTypes;
end;

{ TVA508ManagedComponentClass }

constructor TVA508ManagedComponentClass.Create(AClassType: TWinControlClass;
                     ManageTypes: TManagedTypes; AManageDescendentClasses: boolean = FALSE);
begin
  FClassType := AClassType;
  FManageDescendentClasses := AManageDescendentClasses;
  inherited Create(ManageTypes);
end;

{ TVA508SilentComponent }

function TVA508SilentComponent.GetComponentName(Component: TWinControl): string;
begin
  Result := ComponentManagerSilentText;
end;

function TVA508SilentComponent.GetInstructions(Component: TWinControl): string;
begin
  Result := ComponentManagerSilentText;
end;

function TVA508SilentComponent.GetState(Component: TWinControl): string;
begin
  Result := ComponentManagerSilentText;
end;

function TVA508SilentComponent.GetValue(Component: TWinControl): string;
begin
  Result := ComponentManagerSilentText;
end;

{ TVA508AccessibilityEvents }

constructor TVA508ComponentAccessibility.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  VA508ComponentCreationCheck(Self, AOwner, FALSE, TRUE);
  CreateGlobalRegistry;
end;

procedure TVA508ComponentAccessibility.SetComponent(const Value: TWinControl);
var
  i: integer;
  Comp: TComponent;
begin
  if FComponent <> Value then
  begin
    if assigned(Value) then
    begin
      for i := 0 to Owner.ComponentCount-1 do
      begin
        Comp := Owner.Components[i];
        if (Comp is TVA508ComponentAccessibility) and (Comp <> Self) then
        begin
          if TVA508ComponentAccessibility(Comp).Component = Value then
            raise TVA508Exception.Create(Value.Name + ' is already assigned to another ' +
                    TVA508ComponentAccessibility.ClassName + ' component');
        end;
      end;
      if assigned(GlobalRegistry) then
      begin
        if assigned(FComponent) then
          GlobalRegistry.RegisterFieldObject(FComponent, Self, FALSE);
        GlobalRegistry.RegisterFieldObject(Value, Self, TRUE);
      end;
      FComponent := Value;
    end
    else
    begin
      if assigned(FComponent) and assigned(GlobalRegistry) then
        GlobalRegistry.RegisterFieldObject(FComponent, Self, FALSE);
      FComponent := nil;
    end;
  end;
end;

{ TComponentHelper }

procedure TComponentHelper.InitializeComponentManager;

var
  ClsManager: TVA508ManagedComponentClass;
  CompManager: TVA508ComponentManager;
  data: string;

  procedure InitializeComponentHelper;
  begin
    if assigned(FComponentManager) and FComponentManager.RedirectsComponent(FComponent) then
    begin
      FRedirectedComponent := FComponentManager.Redirect(FComponent, FRedirectedHelperType);
      if FRedirectedComponent.Visible then
      begin
        FRedirectedHelper := GlobalRegistry.GetComponentHelper(FRedirectedComponent.Handle);
        if assigned(FRedirectedHelper) then
          FRedirectedHelper.InitializeComponentManager
        else
          ClearRedirect;

        data := FRedirectedComponent.ClassName + ' / ';
        if assigned(FRedirectedHelper.ComponentManager) then
          data := data + FRedirectedHelper.ComponentManager.ClassName
        else data := data +' no manager';
      end
      else
        ClearRedirect;
    end
    else
      ClearRedirect;
  end;
  
begin
  ClsManager := ManagedClassData;
  CompManager := Manager.ComponentManager[Component];
  if assigned(ClsManager) or assigned(CompManager) then
  begin
    if assigned(CompManager) then
      FComponentManager := CompManager
    else
      FComponentManager := ClsManager;
  end
  else
    FComponentManager := nil;
  InitializeComponentHelper;
end;

procedure TComponentHelper.ClearRedirect;
begin
  FRedirectedHelper := nil;
  FRedirectedHelperType := mtNone;
  FRedirectedComponent := nil;
end;

constructor TComponentHelper.Create;
begin
  ClearRedirect;
end;

destructor TComponentHelper.Destroy;
begin
  if Assigned(GlobalRegistry) and (GlobalRegistry.FCurrentHelper = Self) then
    GlobalRegistry.FCurrentHelper := nil;
  if Assigned(GlobalRegistry) and assigned(GlobalRegistry.FCurrentHelper) and
    (GlobalRegistry.FCurrentHelper.FRedirectedHelper = Self) then
    GlobalRegistry.FCurrentHelper := nil;
  inherited;
end;

function TComponentHelper.GetCaption(var DataResult: Integer): string;
begin
  if Redirect(mtCaption) then
    Result := FRedirectedHelper.GetCaption(DataResult)
  else
  begin
    Result := Manager.ScreenReaderInquiry(FComponent);
    if Result = '' then
    begin
      if assigned(FFieldObject) and (FFieldObject.FCaption <> '') then
        Result := FFieldObject.FCaption
      else
      if assigned(FComponentManager) and FComponentManager.ManageCaption(FComponent) then
        Result := FComponentManager.GetCaption(FComponent)
    end;
    if assigned(FieldObject) and assigned(FieldObject.OnCaptionQuery) then
      FieldObject.OnCaptionQuery(FieldObject, Result);
    if Result <> '' then
      DataResult := DataResult OR DATA_CAPTION;
  end;
end;

function TComponentHelper.GetComponentName(var DataResult: Integer): string;
begin
  if Redirect(mtComponentName) then
    Result := FRedirectedHelper.GetComponentName(DataResult)
  else
  begin
    Result := '';
    if assigned(FFieldObject) and (FFieldObject.FComponentName <> '') then
      Result := FFieldObject.FComponentName
    else if assigned(FComponentManager) and FComponentManager.ManageComponentName(FComponent) then
      Result := FComponentManager.GetComponentName(FComponent);
    if assigned(FFieldObject) and assigned(FFieldObject.FOnComponentNameQuery) then
      FFieldObject.FOnComponentNameQuery(FFieldObject, Result);
    if Result <> '' then
      DataResult := DataResult OR DATA_CONTROL_TYPE;
  end;
end;

function TComponentHelper.GetData(var DataResult: Integer; Value: string): string;
begin
  if Redirect(mtData) then
    Result := FRedirectedHelper.GetData(DataResult, Value)
  else
  begin
    Result := '';
    if assigned(FComponentManager) and FComponentManager.ManageData(FComponent) then
    begin
      Result := FComponentManager.GetData(FComponent, Value);
      if Result <> '' then
        DataResult := DataResult OR DATA_DATA;
    end;
  end;
end;

function TComponentHelper.GetInstructions(var DataResult: Integer): string;
begin
  if Redirect(mtInstructions) then
    Result := FRedirectedHelper.GetInstructions(DataResult)
  else
  begin
    Result := '';
    if assigned(FFieldObject) and (FFieldObject.FInstructions <> '') then
      Result := FFieldObject.FInstructions
    else if assigned(FComponentManager) and FComponentManager.ManageInstructions(FComponent) then
      Result := FComponentManager.GetInstructions(FComponent);
    if assigned(FFieldObject) and assigned(FFieldObject.FOnInstructionsQuery) then
      FFieldObject.FOnInstructionsQuery(FFieldObject, Result);
    if Result <> '' then
      DataResult := DataResult OR DATA_INSTRUCTIONS;
  end;
end;

function TComponentHelper.GetItem: TObject;
begin
  if Redirect(mtItemChange) then
    FRedirectedHelper.GetItem
  else
  begin
    Result := nil;
    if assigned(FComponentManager) and FComponentManager.MonitorForItemChange(FComponent) then
      Result := FComponentManager.GetItem(FComponent);
    if assigned(FFieldObject) and assigned(FFieldObject.FOnItemQuery) then
      FFieldObject.FOnItemQuery(FFieldObject, Result);
  end;
end;

function TComponentHelper.GetItemInstructions(var DataResult: Integer): string;
begin
  if Redirect(mtItemInstructions) then
    Result := FRedirectedHelper.GetItemInstructions(DataResult)
  else
  begin
    Result := '';
    if assigned(FFieldObject) and (FFieldObject.FItemInstructions <> '') then
      Result := FFieldObject.FItemInstructions
    else if assigned(FComponentManager) and FComponentManager.ManageItemInstructions(FComponent) then
      Result := FComponentManager.GetItemInstructions(FComponent);
    if assigned(FFieldObject) and assigned(FFieldObject.FOnItemInstructionsQuery) then
      FFieldObject.FOnItemInstructionsQuery(FFieldObject, Result);
    if Result <> '' then
      DataResult := DataResult OR DATA_ITEM_INSTRUCTIONS;
  end;
end;

function TComponentHelper.GetState(var DataResult: Integer): string;
begin
  Result := '';
  try
    if Redirect(mtState) then
      Result := FRedirectedHelper.GetState(DataResult)
    else
    begin
      if assigned(FComponentManager) and FComponentManager.MonitorForStateChange(FComponent) and
                                              FComponentManager.ManageState(FComponent) then
        Result := FComponentManager.GetState(FComponent);
      if assigned(FFieldObject) and assigned(FFieldObject.FOnStateQuery) then
        FFieldObject.FOnStateQuery(FFieldObject, Result);
      if Result <> '' then
        DataResult := DataResult OR DATA_STATE;
    end;
  except
  // access violations occur here during reminder dialogs - could never figure out why
  // Self = nil when looking at FFieldObject, but checks before that line showed Self <> nil
  end;
end;

function TComponentHelper.GetValue(var DataResult: Integer): string;
begin
  if Redirect(mtValue) then
  begin
    Result := FRedirectedHelper.GetValue(DataResult);
  end
  else
  begin
    Result := '';
    if assigned(FComponentManager) and FComponentManager.ManageValue(FComponent) then
      Result := FComponentManager.GetValue(FComponent);
    if assigned(FFieldObject) and assigned(FFieldObject.FOnValueQuery) then
      FFieldObject.FOnValueQuery(FFieldObject, Result);
    if Result <> '' then
      DataResult := DataResult OR DATA_VALUE;
  end;
end;

function TComponentHelper.ManageComponentName: boolean;
begin
  if Redirect(mtComponentName) then
    Result := FRedirectedHelper.ManageComponentName
  else
  begin
    if assigned(FFieldObject) and
      (assigned(FFieldObject.FOnComponentNameQuery) or (FFieldObject.FComponentName <> '')) then
      Result := TRUE
    else
    begin
      if assigned(FComponentManager) then
        Result := FComponentManager.ManageComponentName(FComponent)
      else
        Result := FALSE;
    end;
  end;
end;

function TComponentHelper.ManageData: boolean;
begin
  if Redirect(mtData) then
    Result := FRedirectedHelper.ManageData
  else
  begin
    if assigned(FComponentManager) then
      Result := FComponentManager.ManageData(FComponent)
    else
      Result := FALSE;
  end;
end;

function TComponentHelper.ManageInstructions: boolean;
begin
  if Redirect(mtInstructions) then
    Result := FRedirectedHelper.ManageInstructions
  else
  begin
    if assigned(FFieldObject) and
      (assigned(FFieldObject.FOnInstructionsQuery) or (FFieldObject.FInstructions <> '')) then
      Result := TRUE
    else
    begin
      if assigned(FComponentManager) then
        Result := FComponentManager.ManageInstructions(FComponent)
      else
        Result := FALSE;
    end;
  end;
end;

function TComponentHelper.ManageItemInstructions: boolean;
begin
  if Redirect(mtItemInstructions) then
    Result := FRedirectedHelper.ManageItemInstructions
  else
  begin
    if assigned(FFieldObject) and
      (assigned(FFieldObject.FOnItemInstructionsQuery) or (FFieldObject.FItemInstructions <> '')) then
      Result := TRUE
    else
    begin
      if assigned(FComponentManager) then
        Result := FComponentManager.ManageItemInstructions(FComponent)
      else
        Result := FALSE;
    end;
  end;
end;

function TComponentHelper.ManageValue: boolean;
begin
  if Redirect(mtValue) then
  begin
    Result := FRedirectedHelper.ManageValue;
  end
  else
  begin
    if assigned(FFieldObject) and assigned(FFieldObject.FOnValueQuery) then
      Result := TRUE
    else
    begin
      if assigned(FComponentManager) then
        Result := FComponentManager.ManageValue(FComponent)
      else
        Result := FALSE;
    end;
  end;
end;

function TComponentHelper.ManageCaption: boolean;
begin
  if Redirect(mtCaption) then
    Result := FRedirectedHelper.ManageCaption
  else
  begin
    if assigned(FFieldObject) and
      (assigned(FFieldObject.OnCaptionQuery) or (FFieldObject.FCaption <> '')) then
      Result := TRUE
    else
    begin
      if assigned(FComponentManager) then
        Result := FComponentManager.ManageCaption(FComponent)
      else
        Result := FALSE;
    end;
  end;
end;

function TComponentHelper.MonitorForItemChange: boolean;
begin
  if Redirect(mtItemChange) then
    Result := FRedirectedHelper.MonitorForItemChange
  else
  begin
    if assigned(FFieldObject) and assigned(FFieldObject.FOnItemQuery) then
      Result := TRUE
    else
    begin
      if assigned(FComponentManager) then
        Result := FComponentManager.MonitorForItemChange(FComponent)
      else
        Result := FALSE;
    end;
  end;
end;

function TComponentHelper.MonitorForStateChange: boolean;
begin
  if Redirect(mtStateChange) then
    Result := FRedirectedHelper.MonitorForStateChange
  else
  begin
    if assigned(FFieldObject) and assigned(FFieldObject.OnStateQuery) then
      Result := TRUE
    else
    begin
      if assigned(FComponentManager) then
        Result := FComponentManager.MonitorForStateChange(FComponent) and
                  FComponentManager.ManageState(FComponent)
      else
        Result := FALSE;
    end;
  end;
end;

function TComponentHelper.Redirect(RedirectType: TManagedType): boolean;
begin
  Result := FALSE;
  if assigned(FRedirectedHelper) and assigned(FRedirectedComponent) and
     (FRedirectedHelperType = RedirectType) then
    Result := TRUE;
end;

function TComponentHelper.StandardComponent: boolean;
begin
  Result := ((not assigned(FComponentManager)) and (not assigned(FFieldObject)));
end;

{ TVA508StaticText }
type
  TFriendLabel = class(TLabel);

procedure TVA508StaticText.CMFontChanged(var Message: TMessage);
begin
  inherited;
  UpdateSize;
end;

procedure TVA508StaticText.CMTextChanged(var Message: TMessage);
begin
  inherited;
  UpdateSize;
end;

constructor TVA508StaticText.Create;
begin
  inherited;
  FLabel := TLabel.Create(Self);
  FLabel.Parent := Self;
  FLabel.Align := alClient;
  ControlStyle := ControlStyle - [csAcceptsControls];
  FInitTabStop := (not TabStop);
end;

procedure TVA508StaticText.DeleteChain(FromLabel, ToLabel: TVA508ChainedLabel);
var
  next, lbl: TVA508ChainedLabel;
  prev: TControl;
begin
  if FDeletingChain then exit;
  if FromLabel = ToLabel then exit;    
  FDeletingChain := TRUE;
  try
    next := NextLabel;
    while assigned(next) and (next <> FromLabel) do
      next := next.NextLabel;
    if assigned(next) then
    begin
      prev := next.FPreviousLabel;
      repeat
        lbl := next;
        next := next.NextLabel;
        lbl.Free;
      until (not assigned(next)) or (next = ToLabel);
      if assigned(ToLabel) then
        ToLabel.FPreviousLabel := prev;
    end;
  finally
    FDeletingChain := FALSE;
  end;
end;

destructor TVA508StaticText.Destroy;
begin
  if assigned(FNextLabel) then
    DeleteChain(FNextLabel, nil);
  inherited;
end;

procedure TVA508StaticText.DoEnter;
begin
  inherited DoEnter;
  InvalidateAll;
  if Assigned(FOnEnter) then
     FOnEnter(Self);
end;

procedure TVA508StaticText.DoExit;
begin
  inherited DoExit;
  InvalidateAll;
  if Assigned(FOnExit) then
     FOnExit(Self);
end;

function TVA508StaticText.GetAlignment: TAlignment;
begin
  Result := FLabel.Alignment;
end;

function TVA508StaticText.GetLabelCaption: string;
begin
  Result := FLabel.Caption;
end;

function TVA508StaticText.GetRootName: string;
begin
  result := inherited Name;
end;

function TVA508StaticText.GetShowAccelChar: boolean;
begin
  Result := FLabel.ShowAccelChar;
end;

procedure TVA508StaticText.InvalidateAll;
var
  next: TVA508ChainedLabel;
begin
  invalidate;
  next := FNextLabel;
  while assigned(next) do
  begin
    next.Invalidate;
    next := next.NextLabel;
  end;
end;

procedure TVA508StaticText.Notification(AComponent: TComponent; Operation: TOperation);
begin
  inherited;
  if csDestroying in ComponentState then exit;
  if (Operation = opRemove) and (AComponent = FNextLabel) and (not FDeletingChain) then
    SetNextLabel(nil);
end;

procedure TVA508StaticText.Paint;
var
  x1, x2, y1, y2: integer;

  procedure Init;
  begin
    Canvas.Font := Self.Font;
    with Canvas do
    begin
      Pen.Width := 1;
      Brush.Color := clNone;
      Brush.Style := bsClear;
    end;
  end;

//  procedure DrawText;
//  begin
//    with Canvas do
//    begin
//      Pen.color := Self.Font.Color;
//      Pen.Style := psSolid;
//      TextOut(1, 0, Caption);
//    end;
//  end;

  procedure InitDrawBorder;
  var
    r: TRect;
  begin
    with Canvas do
    begin
      if Focused then
      begin
        Pen.Style := psDot;
        Pen.Color := Self.Font.Color;
      end
      else
      begin
        Pen.Style := psSolid;
        pen.Color := Self.Color;
      end;
    end;
    R := ClientRect;
    R.Bottom := R.Bottom - 1;
    R.Right := R.Right - 1;
    x1 := R.Left;
    y1 := R.Top;
    x2 := R.Right;
    y2 := R.Bottom;
  end;

  procedure DrawTop;
  begin
    With Canvas do
    begin
      MoveTo(x1, y2);
      LineTo(x1, y1);
      LineTo(x2, y1);
      LineTo(x2, y2);
    end;
  end;

  procedure DrawBottom;
  var
    bx1,bx2, max: integer;
    r: TRect;
    r2: TRect;
  begin
    with Canvas do
    begin
      if assigned(FNextLabel) then
      begin
        r := BoundsRect;
        r2 := FNextLabel.BoundsRect;
        if r.top < r2.top then
        begin
          bx1 := r2.Left - r.Left;
          if (bx1 > 0) then
          begin
            if bx1 > x2 then
              max := x2
            else
              max := bx1;
            moveto(x1,y2);
            lineto(max,y2);
          end;
          bx2 := x2 - (r.Right - r2.Right);
          if bx2 < x2 then
          begin
            if bx2 < x1 then
              max := x1
            else
              max := bx2;
            moveto(x2,y2);
            lineto(max,y2);
          end;
        end;
      end
      else
        LineTo(x1, y2);
    end;
  end;
  
begin
  Init;
//  if Focused then
//    DrawText;
  InitDrawBorder;
  DrawTop;
  DrawBottom;
//  if not Focused then
//    DrawText;
end;

procedure TVA508StaticText.SetAlignment(const Value: TAlignment);
begin
  FLabel.Alignment := Value;
end;

procedure TVA508StaticText.SetLabelCaption(const Value: string);
begin
  if FLabel.Caption <> Value then
  begin
    FLabel.Caption := Value;
    UpdateSize;
  end;
end;

procedure TVA508StaticText.SetRootName(const Value: string);
begin
  if inherited Name <> Value then
  begin
    if FLabel.Caption = inherited Name then
      FLabel.Caption := Value;
    inherited Name := Value;
    inherited Caption := '';
  end;
end;

procedure TVA508StaticText.SetNextLabel(const Value: TVA508ChainedLabel);
begin
  if FNextLabel <> Value then
  begin
    if assigned(FNextLabel) then
      DeleteChain(FNextLabel, Value);
    FNextLabel := Value;
    if assigned(FNextLabel) then
    begin
      FNextLabel.FStaticLabelParent := Self;
      FNextLabel.FPreviousLabel := Self;
    end;
    invalidate;
  end;
end;

procedure TVA508StaticText.SetParent(AParent: TWinControl);
begin
  inherited SetParent(AParent);
  if assigned(AParent) then
  begin
    if FInitTabStop then
    begin
      if csDesigning in ComponentState then
        TabStop := FALSE
      else
        TabStop := ScreenReaderActive;
      FInitTabStop := FALSE;
    end;
    Perform(CM_FONTCHANGED, 0, 0);
  end;
end;

procedure TVA508StaticText.SetShowAccelChar(const Value: boolean);
begin
  FLabel.ShowAccelChar := Value;
end;

procedure TVA508StaticText.UpdateSize;
begin
  FLabel.Align := alNone;
  try
    TFriendLabel(FLabel).AdjustBounds;
    Height := FLabel.Height + 2;
    Width := FLabel.Width + 2;
  finally
    FLabel.Align := alClient;
  end;
end;

{ TVA508ChainedLabel }

procedure TVA508ChainedLabel.Notification(AComponent: TComponent;
  Operation: TOperation);
begin
  inherited;
  if not assigned(FStaticLabelParent) then exit;
  if csDestroying in ComponentState then exit;
  if (Operation = opRemove) and (AComponent = FNextLabel) and (not FStaticLabelParent.FDeletingChain) then
    SetNextLabel(nil);
end;

procedure TVA508ChainedLabel.Paint;
var
  x1, x2, y1, y2: integer;

  procedure Init;
  begin
    Canvas.Font := Self.Font;
    with Canvas do
    begin
      Pen.Width := 1;
      Brush.Color := clNone;
      Brush.Style := bsClear;
    end;
  end;

  procedure DrawText;
  begin
    with Canvas do
    begin
      Pen.color := Self.Font.Color;
      Pen.Style := psSolid;
      TextOut(0, 0, Caption);
    end;
  end;

  procedure InitDrawBorder;
  var
    r: TRect;
  begin
    with Canvas do
    begin
      if FStaticLabelParent.Focused then
      begin
        Pen.Style := psDot;
        Pen.Color := Self.Font.Color;
      end
      else
      begin
        if transparent then
        begin
          Pen.Style := psClear;
          Pen.Color := clNone;
        end
        else
        begin
          Pen.Style := psSolid;
          pen.Color := Self.Color;
        end;
      end;
    end;
    R := ClientRect;
    R.Bottom := R.Bottom - 1;
    R.Right := R.Right - 1;
    x1 := R.Left;
    y1 := R.Top;
    x2 := R.Right;
    y2 := R.Bottom;
  end;

  procedure DrawPartials(x3, x4, y: integer);
  var
    max: integer;
  begin
    with Canvas do
    begin
      if (x3 > x1) then
      begin
        if x3 > x2 then
          max := x2
        else
          max := x3;
        moveto(x1,y);
        lineto(max,y);
      end;
      if x4 < x2 then
      begin
        if x4 < x1 then
          max := x1
        else
          max := x4;
        moveto(x2,y);
        lineto(max,y);
      end;
    end;
  end;

  procedure DrawTop;
  var
    r, r2: TRect;
    tx1,tx2: integer;
  begin
    With Canvas do
    begin
      r2 := BoundsRect;
      r := FPreviousLabel.BoundsRect;
      if r.top < r2.top then
      begin
        tx1 := r.Left - r2.Left;
        tx2 := x2 - (r2.Right - r.Right);
        DrawPartials(tx1,tx2,y1);
      end
      else
      begin
        MoveTo(x1, y1);
        LineTo(x2, y1);
      end;
    end;
  end;

  procedure DrawSides;
  begin
    With Canvas do
    begin
      MoveTo(x1,y1);
      LineTo(x1,y2);
      MoveTo(x2,y1);
      LineTo(x2,y2);
    end;
  end;

  procedure DrawBottom;
  var
    r, r2: TRect;
    doBottom: boolean;
    bx1,bx2: integer;
  begin
    With Canvas do
    begin
      if assigned(FNextLabel) then
      begin
        r := BoundsRect;
        r2 := FNextLabel.BoundsRect;
        if r.top < r2.top then
        begin
          doBottom := FALSE;
          bx1 := r2.Left - r.Left;
          bx2 := x2 - (r.Right - r2.Right);
          DrawPartials(bx1,bx2,y2);
        end
        else
          doBottom := TRUE;
      end
      else
        doBottom := TRUE;
      if DoBottom then
      begin
        MoveTo(x1, y2);
        LineTo(x2, y2);
      end;
    end;
  end;
  
begin
  Init;
  if FStaticLabelParent.Focused then
    DrawText;
  InitDrawBorder;
  DrawTop;
  DrawSides;
  DrawBottom;
  if not FStaticLabelParent.Focused then
    DrawText;
end;

procedure TVA508ChainedLabel.SetNextLabel(const Value: TVA508ChainedLabel);
begin
  if not assigned(FStaticLabelParent) then exit;
  if FNextLabel <> Value then
  begin
    if assigned(FNextLabel) then
      FStaticLabelParent.DeleteChain(FNextLabel, Value);
    FNextLabel := Value;
    if assigned(FNextLabel) then
    begin
      FNextLabel.FStaticLabelParent := FStaticLabelParent;
      FNextLabel.FPreviousLabel := Self;
    end;
    invalidate;
  end;
end;

{ TVA508ComplexComponentManager }

type
  TComplexDataItem = class(TObject)
  private
    FList: TList;
    FComponent: TWinControl;
    FSubComponent: TWinControl;
  public
    constructor Create(Component, SubComponent: TWinControl);
    destructor Destroy; override;
  end;

{ TComplexDataItem }

constructor TComplexDataItem.Create(Component, SubComponent: TWinControl);
begin
  FComponent := Component;
  FSubComponent := SubComponent;
  if assigned(FSubComponent) then
    FList := nil
  else
    FList := TList.Create;
end;

destructor TComplexDataItem.Destroy;
begin
  if assigned(FList) then
    FList.Free;
  inherited;
end;


procedure TVA508ComplexComponentManager.AddSubControl(ParentComponent, SubControl: TWinControl;
                            AccessibilityManager: TVA508AccessibilityManager);
var
  list: TList;
  item : TComplexDataItem;
begin
  if (not assigned(ParentComponent)) or (not assigned(SubControl)) then exit;
  list := GetSubComponentList(ParentComponent);
  if list.IndexOf(SubControl) < 0 then
  begin
    list.Add(SubControl);
    if IndexOfSubComponentXRef(SubControl) < 0 then
    begin
      item := TComplexDataItem.Create(ParentComponent, SubControl);
      FSubComponentXRef.Add(item);
      SubControl.FreeNotification(FSubComponentNotifier);
    end;
    if assigned(AccessibilityManager) and assigned(GlobalRegistry) then
      GlobalRegistry.RegisterComponent(SubControl, AccessibilityManager);
  end;
end;

procedure TVA508ComplexComponentManager.RemoveSubControl(ParentComponent, SubControl: TWinControl);
var
  list: TList;
  idx: integer;
begin
  if (not assigned(ParentComponent)) or (not assigned(SubControl)) then exit;
  list := GetSubComponentList(ParentComponent);
  idx := list.IndexOf(SubControl);
  if idx >= 0 then
  begin
    List.Delete(idx);
    idx := IndexOfSubComponentXRef(SubControl);
    if idx >= 0 then
    begin
      FSubComponentXRef.Delete(idx);
      SubControl.RemoveFreeNotification(FSubComponentNotifier);
    end;
    if assigned(GlobalRegistry) then
      GlobalRegistry.UnregisterComponent(SubControl);
  end;
end;

procedure TVA508ComplexComponentManager.ClearSubControls(Component: TWinControl);
var
  list: TList;
  idx, i: integer;
  SubControl: TWinControl;

begin
  if (not assigned(Component)) then exit;
  list := GetSubComponentList(Component);
  for i := 0 to list.Count - 1 do
  begin
    SubControl := TWinControl(list[i]);
    idx := IndexOfSubComponentXRef(SubControl);
    if idx >= 0 then
    begin
      FSubComponentXRef.Delete(idx);
      SubControl.RemoveFreeNotification(FSubComponentNotifier);
    end;
    if assigned(GlobalRegistry) then
      GlobalRegistry.UnregisterComponent(SubControl);
  end;
  list.Clear;
end;

constructor TVA508ComplexComponentManager.Create(
  AComponentClass: TWinControlClass);
begin
  FComponentClass := AComponentClass;
  FComponentNotifier := TVANotificationEventComponent.NotifyCreate(nil, ComponentNotifyEvent);
  FSubComponentNotifier := TVANotificationEventComponent.NotifyCreate(nil, SubComponentNotifyEvent);
  FComponentList := TObjectList.Create;
  FSubComponentXRef := TObjectList.Create;
end;

destructor TVA508ComplexComponentManager.Destroy;
begin
  FSubComponentXRef.Free;
  FComponentList.Free;
  FComponentNotifier.Free;
  FSubComponentNotifier.Free;
  inherited;
end;

function TVA508ComplexComponentManager.GetSubComponentList(Component: TWinControl): TList;
var
  i: integer;
  item: TComplexDataItem;
begin
  i := IndexOfComponentItem(Component);
  if i < 0 then
  begin
    item := TComplexDataItem.Create(Component, nil);
    i := FComponentList.Add(item);
    Component.FreeNotification(FComponentNotifier);
  end;
  Result := TComplexDataItem(FComponentList[i]).FList;
end;

function TVA508ComplexComponentManager.GetSubControl(Component: TWinControl;
  Index: integer): TWinControl;
begin
  if assigned(Component) then
    Result := TWinControl(GetSubComponentList(Component)[Index])
  else
    Result := nil;
end;

function TVA508ComplexComponentManager.IndexOfComponentItem(
  Component: TWinControl): integer;
var
  i:integer;
  item: TComplexDataItem;
begin
  for i := 0 to FComponentList.Count -1 do
  begin
    item := TComplexDataItem(FComponentList[i]);
    if item.FComponent = Component then
    begin
      Result := i;
      exit;
    end;
  end;
  Result := -1;
end;

function TVA508ComplexComponentManager.IndexOfSubComponentXRef(
  Component: TWinControl): integer;
var
  i:integer;
  item: TComplexDataItem;
begin
  for i := 0 to FSubComponentXRef.Count -1 do
  begin
    item := TComplexDataItem(FSubComponentXRef[i]);
    if item.FSubComponent = Component then
    begin
      Result := i;
      exit;
    end;
  end;
  Result := -1;
end;

procedure TVA508ComplexComponentManager.ComponentNotifyEvent(AComponent: TComponent;
  Operation: TOperation);
var
  idx: integer;
begin
  if (Operation = opRemove) and assigned(AComponent) and (AComponent is TWinControl) then
  begin
    ClearSubControls(TWinControl(AComponent));
    idx := IndexOfComponentItem(TWinControl(AComponent));
    if idx >= 0 then
      FComponentList.Delete(idx);
  end;
end;

procedure TVA508ComplexComponentManager.SubComponentNotifyEvent(
  AComponent: TComponent; Operation: TOperation);
var
  idx: integer;
  Parent: TWinControl;
  item: TComplexDataItem;
begin
  if (Operation = opRemove) and assigned(AComponent) and (AComponent is TWinControl) then
  begin
    idx := IndexOfSubComponentXRef(TWinControl(AComponent));
    if idx >= 0 then
    begin
      item := TComplexDataItem(FSubComponentXRef[idx]);
      Parent := item.FComponent;
      RemoveSubControl(Parent, TWinControl(AComponent));
    end;
  end;
end;

function TVA508ComplexComponentManager.SubControlCount(Component: TWinControl): integer;
begin
  if assigned(Component) then
    Result := GetSubComponentList(Component).Count
  else
    Result := 0;
end;

initialization

finalization
  FreeGlobalVars;

end.

