Creating Accessible UI components in Delphi

Question

I am trying to retrieve accessible information from a standard VCL TEdit control. The get_accName() and Get_accDescription() methods return empty strings, but get_accValue() returns the text value entered into the TEdit.

I am just starting to try to understand the MSAA and I'm a bit lost at this point.

Does my TEdit need to have additional published properties that would be exposed to the MSA? If so would that necessitate creating a new component that descends from TEdit and adds the additional published properties such as "AccessibleName", "AccessibleDescription", etc... ?

Also, note, I have looked at the VTVirtualTrees component which is supposed to be accessible, but the MS Active Accessibility Object Inspector still does not see the AccessibleName published property even on that control.

At this point I am at a loss and would be grateful for any advice or help in this matter.

...
interface
uses
   Winapi.Windows,
   Winapi.Messages,
   System.SysUtils,
   System.Variants,
   System.Classes,
   Vcl.Graphics,
   Vcl.Controls,
   Vcl.Forms,
   Vcl.Dialogs,
   Vcl.StdCtrls,
   Vcl.ComCtrls,
   Vcl.ExtCtrls,
   oleacc;

const
  WM_GETOBJECT = $003D; // Windows MSAA message identifier
  OBJID_NATIVEOM = $FFFFFFF0;

type
  TForm1 = class(TForm)
    lblFirstName: TLabel;
    edFirstName: TEdit;
    panel1: TPanel;
    btnGetAccInfo: TButton;
    accInfoOutput: TEdit;
    procedure btnGetAccInfoClick(Sender: TObject);
    procedure edFirstNameChange(Sender: TObject);
  private
    { Private declarations }
    FFocusedAccessibleObj: IAccessible;
    FvtChild: Variant;
    FAccProperties: TStringList;
    FAccName: string;
    FAccDesc: string;
    FAccValue: string;
    procedure DoGetAccessibleObjectFromPoint(aPoint: TPoint);
  public
   { Public declarations }
   procedure BeforeDestruction; override;
   property AccName: string read FAccName;
   property AccDescription: string read FAccName;
   property AccValue: string read FAccName;
  end;

var
  Form1: TForm1;

const
  cCRLF = #13#10;

implementation

{$R *.dfm}

function AccessibleObjectFromPoint(ptScreen: TPoint;
                                   out ppacc: IAccessible;
                                   out pvarChildt: Variant): HRESULT; stdcall; external   'oleacc.dll' ;

{------------------------------------------------------------------------------}
procedure TForm1.BeforeDestruction;
begin
  VarClear(FvtChild);
  FFocusedAccessibleObj := nil;
end;

{------------------------------------------------------------------------------}
procedure TForm1.DoGetAccessibleObjectFromPoint(aPoint: TPoint);
var
  pt: TPoint;
  bsName: WideString;
  bsDesc: WideString;
  bsValue: WideString;
begin
  if (SUCCEEDED(AccessibleObjectFromPoint(aPoint, FFocusedAccessibleObj, FvtChild))) then
    try
      // get_accName  returns an empty string
      bsName := '';
      FFocusedAccessibleObj.get_accName(FvtChild, bsName);
      FAccName := bsName;
      FAccProperties.Add('Acc Name: ' + FAccName + '  |  ' + cCRLF);

      // Get_accDescription  returns an empty string
      bsDesc := '';
      FFocusedAccessibleObj.Get_accDescription(FvtChild, bsDesc);
      FAccDesc := bsDesc;
      FAccProperties.Add('Acc Description: ' + FAccDesc + '  |  ' + cCRLF);

      // this works
      bsValue := '';
      FFocusedAccessibleObj.get_accValue(FvtChild, bsValue);
      FAccValue := bsValue;
      FAccProperties.Add('Acc Value: ' + FAccValue  + cCRLF);

   finally
     VarClear(FvtChild);
     FFocusedAccessibleObj := nil ;
   end;
  end;

  {------------------------------------------------------------------------------}
  procedure TForm1.btnGetAccInfoClick(Sender: TObject);
  begin
    FAccProperties := TStringList.Create;
    DoGetAccessibleObjectFromPoint(edFirstName.ClientOrigin);
    accInfoOutput.Text := FAccProperties.Text;
  end;   
end.

Jylland

Answer 1

I was able to get this working via

unit mainAcc;

interface

uses
    Winapi.Windows,
    Winapi.Messages,
    System.SysUtils,
    System.Variants,
    System.Classes,
    Vcl.Graphics,
    Vcl.Controls,
    Vcl.Forms,
    Vcl.Dialogs,
    Vcl.StdCtrls,
    Vcl.ComCtrls,
    Vcl.ExtCtrls,
    oleacc;

type
    TForm1 = class(TForm)
        lblFirstName: TLabel;
        btnGetAccInfo: TButton;
        accInfoOutput: TEdit;
        procedure btnGetAccInfoClick(Sender: TObject);
        procedure FormCreate(Sender: TObject);
        procedure FormClose(Sender: TObject; var Action: TCloseAction);
    private
        { Private declarations }
        aEdit: TTWEdit;
        FAccProperties: TStringList;
    public
        { Public declarations }
    end;

    TAccessibleEdit = class(TEdit, IAccessible)
    private
        FOwner: TComponent;
        FAccessibleItem: IAccessible;
        FAccessibleName: string;
        FAccessibleDescription: string;
        procedure WMGetMSAAObject(var Message : TMessage); message WM_GETOBJECT;
        // IAccessible
        function Get_accParent(out ppdispParent: IDispatch): HResult; stdcall;
        function Get_accChildCount(out pcountChildren: Integer): HResult; stdcall;
        function Get_accChild(varChild: OleVariant; out ppdispChild: IDispatch): HResult; stdcall;
        function Get_accName(varChild: OleVariant; out pszName: WideString): HResult; stdcall;
        function Get_accValue(varChild: OleVariant; out pszValue: WideString): HResult; stdcall;
        function Get_accDescription(varChild: OleVariant; out pszDescription: WideString): HResult; stdcall;
        function Get_accRole(varChild: OleVariant; out pvarRole: OleVariant): HResult; stdcall;
        function Get_accState(varChild: OleVariant; out pvarState: OleVariant): HResult; stdcall;
        function Get_accHelp(varChild: OleVariant; out pszHelp: WideString): HResult; stdcall;
        function Get_accHelpTopic(out pszHelpFile: WideString; varChild: OleVariant;
                                                            out pidTopic: Integer): HResult; stdcall;
        function Get_accKeyboardShortcut(varChild: OleVariant; out pszKeyboardShortcut: WideString): HResult; stdcall;
        function Get_accFocus(out pvarChild: OleVariant): HResult; stdcall;
        function Get_accSelection(out pvarChildren: OleVariant): HResult; stdcall;
        function Get_accDefaultAction(varChild: OleVariant; out pszDefaultAction: WideString): HResult; stdcall;
        function accSelect(flagsSelect: Integer; varChild: OleVariant): HResult; stdcall;
        function accLocation(out pxLeft: Integer; out pyTop: Integer; out pcxWidth: Integer;
                                                 out pcyHeight: Integer; varChild: OleVariant): HResult; stdcall;
        function accNavigate(navDir: Integer; varStart: OleVariant; out pvarEndUpAt: OleVariant): HResult; stdcall;
        function accHitTest(xLeft: Integer; yTop: Integer; out pvarChild: OleVariant): HResult; stdcall;
        function accDoDefaultAction(varChild: OleVariant): HResult; stdcall;
        function Set_accName(varChild: OleVariant; const pszName: WideString): HResult; stdcall;
        function Set_accValue(varChild: OleVariant; const pszValue: WideString): HResult; stdcall;
    protected
        function QueryInterface(const IID: TGUID; out Obj): HResult; override;
    public
        constructor Create(AOwner: TComponent); override;
    published
        property AccessibleItem: IAccessible read FAccessibleItem write FAccessibleItem;
        property AccessibleName: string read FAccessibleName write FAccessibleName;
        property AccessibleDescription: string read FAccessibleDescription write FAccessibleDescription;
    end;

var
    Form1: TForm1;

implementation

{$R *.dfm}

{------------------------------------------------------------------------------}
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
    inherited;
    FreeAndNil(aEdit);
end;

{------------------------------------------------------------------------------}
procedure TForm1.FormCreate(Sender: TObject);
begin
    aEdit := TAccessibleEdit.Create(self);
    aEdit.Visible := true;
    aEdit.Parent := Form1;
    aEdit.Left := 91;
    aEdit.Top := 17;
    aEdit.Height := 21;
    aEdit.Width := 204;
    aEdit.Hint := 'This is a custom accessible edit control hint';
end;

{------------------------------------------------------------------------------}
procedure TForm1.btnGetAccInfoClick(Sender: TObject);
var
    vWSTemp: WideString;
    vAccObj: IAccessible;
begin
    FAccProperties := TStringList.Create;
    if (AccessibleObjectFromWindow(aEdit.Handle, OBJID_CLIENT, IID_IAccessible, vAccObj) = S_OK) then
    begin
        vAccObj.Get_accName(CHILDID_SELF, vWSTemp);
        FAccProperties.Add('Name: ' + vWSTemp);
        vWSTemp := '';
        vAccObj.Get_accDescription(CHILDID_SELF, vWSTemp);
        FAccProperties.Add('Description: ' + vWSTemp);
        vWSTemp := '';
        vAccObj.Get_accValue(CHILDID_SELF, vWSTemp);
        FAccProperties.Add('Value: ' + vWSTemp);
    end;
    accInfoOutput.Text := FAccProperties.Text;
end;


        { TAccessibleEdit }
    {------------------------------------------------------------------------------}
    constructor TAccessibleEdit.Create(AOwner: TComponent);
    begin
        inherited Create(AOwner);
        FOwner := AOwner;
    end;

    {------------------------------------------------------------------------------}
    function TAccessibleEdit.QueryInterface(const IID: TGUID; out Obj): HResult;
    begin
        if GetInterface(IID, Obj) then
            Result := 0
        else
            Result := E_NOINTERFACE;
    end;

    {------------------------------------------------------------------------------}
    function TAccessibleEdit.accDoDefaultAction(varChild: OleVariant): HResult;
    begin
        Result := DISP_E_MEMBERNOTFOUND;
    end;

    {------------------------------------------------------------------------------}
    function TAccessibleEdit.accHitTest(xLeft, yTop: Integer;
        out pvarChild: OleVariant): HResult;
    begin
        Result := DISP_E_MEMBERNOTFOUND;
    end;

    {------------------------------------------------------------------------------}
    function TAccessibleEdit.accLocation(out pxLeft, pyTop, pcxWidth, pcyHeight: Integer;
        varChild: OleVariant): HResult;
    var
        P: TPoint;
    begin
        Result := S_FALSE;
        pxLeft := 0;
        pyTop := 0;
        pcxWidth := 0;
        pcyHeight := 0;
        if varChild = CHILDID_SELF then
        begin
            P := self.ClientToScreen(self.ClientRect.TopLeft);
            pxLeft := P.X;
            pyTop := P.Y;
            pcxWidth := self.Width;
            pcyHeight := self.Height;
            Result := S_OK;
        end
    end;

    {------------------------------------------------------------------------------}
    function TAccessibleEdit.accNavigate(navDir: Integer; varStart: OleVariant;
        out pvarEndUpAt: OleVariant): HResult;
    begin
        result := DISP_E_MEMBERNOTFOUND;
    end;

    {------------------------------------------------------------------------------}
    function TAccessibleEdit.accSelect(flagsSelect: Integer; varChild: OleVariant): HResult;
    begin
        Result := DISP_E_MEMBERNOTFOUND;
    end;

    {------------------------------------------------------------------------------}
    function TAccessibleEdit.Get_accChild(varChild: OleVariant;
        out ppdispChild: IDispatch): HResult;
    begin
        Result := DISP_E_MEMBERNOTFOUND;
    end;

    {------------------------------------------------------------------------------}
    function TAccessibleEdit.Get_accChildCount(out pcountChildren: Integer): HResult;
    begin
        Result := DISP_E_MEMBERNOTFOUND;
    end;

    {------------------------------------------------------------------------------}
    function TAccessibleEdit.Get_accDefaultAction(varChild: OleVariant;
        out pszDefaultAction: WideString): HResult;
    begin
        Result := DISP_E_MEMBERNOTFOUND;
    end;

    {------------------------------------------------------------------------------}
    function TAccessibleEdit.Get_accDescription(varChild: OleVariant;
        out pszDescription: WideString): HResult;
    begin
        pszDescription := '';
        result := S_FALSE;
        if varChild = CHILDID_SELF then
        begin
            pszDescription := 'TAccessibleEdit_AccessibleDescription';
            Result := S_OK;
        end;
    end;

    {------------------------------------------------------------------------------}
    function TAccessibleEdit.Get_accFocus(out pvarChild: OleVariant): HResult;
    begin
        Result := DISP_E_MEMBERNOTFOUND;
    end;

    {------------------------------------------------------------------------------}
    function TAccessibleEdit.Get_accHelp(varChild: OleVariant;
        out pszHelp: WideString): HResult;
    begin
        Result := DISP_E_MEMBERNOTFOUND;
    end;

    {------------------------------------------------------------------------------}
    function TAccessibleEdit.Get_accHelpTopic(out pszHelpFile: WideString;
        varChild: OleVariant; out pidTopic: Integer): HResult;
    begin
        pszHelpFile := '';
        pidTopic := 0;
        Result := S_FALSE;
        if varChild = CHILDID_SELF then
        begin
            pszHelpFile := '';
            pidTopic := self.HelpContext;
            Result := S_OK;
        end;
    end;

    {------------------------------------------------------------------------------}
    function TAccessibleEdit.Get_accKeyboardShortcut(varChild: OleVariant;
        out pszKeyboardShortcut: WideString): HResult;
    begin
        Result := DISP_E_MEMBERNOTFOUND;
    end;

    {------------------------------------------------------------------------------}
    function TAccessibleEdit.Get_accName(varChild: OleVariant; out pszName: WideString): HResult;
    begin
        pszName := '';
        Result := S_FALSE;
        if varChild = CHILDID_SELF then
        begin
            pszName := 'TAccessibleEdit_AccessibleName';
            result := S_OK;
        end;
    end;

    {------------------------------------------------------------------------------}
    function TAccessibleEdit.Get_accParent(out ppdispParent: IDispatch): HResult;
    begin
        ppdispParent := nil;
        result := AccessibleObjectFromWindow(self.ParentWindow, CHILDID_SELF, IID_IAccessible, Pointer(ppDispParent));
    end;

    {------------------------------------------------------------------------------}
    function TAccessibleEdit.Get_accRole(varChild: OleVariant;
        out pvarRole: OleVariant): HResult;
    begin
        Result := S_OK;
        if varChild = CHILDID_SELF then
            pvarRole := ROLE_SYSTEM_OUTLINE;
    end;

    {------------------------------------------------------------------------------}
    function TAccessibleEdit.Get_accSelection(out pvarChildren: OleVariant): HResult;
    begin
        Result := DISP_E_MEMBERNOTFOUND;
    end;

    {------------------------------------------------------------------------------}
    function TAccessibleEdit.Get_accState(varChild: OleVariant;
        out pvarState: OleVariant): HResult;
    begin
        Result := S_OK;
        if varChild = CHILDID_SELF then
            pvarState := STATE_SYSTEM_FOCUSED;
    end;

    {------------------------------------------------------------------------------}
    function TAccessibleEdit.Get_accValue(varChild: OleVariant;
        out pszValue: WideString): HResult;
    begin
        pszValue := '';
        Result := S_FALSE;
        if varChild = CHILDID_SELF then
        begin
            pszValue := WideString(self.Text);
            result := S_OK;
        end;
    end;

    {------------------------------------------------------------------------------}
    function TAccessibleEdit.Set_accName(varChild: OleVariant;
        const pszName: WideString): HResult;
    begin
        Result := DISP_E_MEMBERNOTFOUND;
    end;

    {------------------------------------------------------------------------------}
    function TAccessibleEdit.Set_accValue(varChild: OleVariant;
        const pszValue: WideString): HResult;
    begin
        Result := DISP_E_MEMBERNOTFOUND;
    end;

    {------------------------------------------------------------------------------}
    procedure TAccessibleEdit.WMGetMSAAObject(var Message : TMessage);
    begin
        if (Message.Msg = WM_GETOBJECT) then
        begin
            QueryInterface(IID_IAccessible, FAccessibleItem);
            Message.Result := LresultFromObject(IID_IAccessible, Message.WParam, FAccessibleItem);
        end
        else
            Message.Result := DefWindowProc(Handle, Message.Msg, Message.WParam, Message.LParam);
    end;

    end. 

end.

Jylland

Shame on you for accepting your own answer instead of Remy's which led you to the solution to your problem! You should give credit where it is due. Remy's detailed answer deserves upvoting and acceptance. – Whosoever

Answer 2

The VCL itself does not natively implement any support for MSAA. Windows provides default implementations for standard UI controls, which many standard VCL components wrap. If you need more MSAA support than Windows provides, you will have to implement the IAccessible interface yourself, and then have your control respond to the WM_GETOBJECT message so it can return a pointer to an instance of your implementation.

Update: For example, one way to add MSAA to an existing TEdit (if you do not want to derive your own component) might look something like this:

uses
  ..., oleacc;

type
  TMyAccessibleEdit = class(TInterfacedObject, IAccessible)
  private
    fEdit: TEdit;
    fDefAcc: IAccessible;
  public
    constructor Create(aEdit: TEdit; aDefAcc: IAccessible);

    function QueryInterface(const IID: TGUID; out Obj): HResult; virtual; stdcall;

    function GetTypeInfoCount(out Count: Integer): HResult; stdcall;
    function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall;
    function GetIDsOfNames(const IID: TGUID; Names: Pointer; NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall;
    function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall;

    function Get_accParent(out ppdispParent: IDispatch): HResult; stdcall;
    function Get_accChildCount(out pcountChildren: Integer): HResult; stdcall;
    function Get_accChild(varChild: OleVariant; out ppdispChild: IDispatch): HResult; stdcall;
    function Get_accName(varChild: OleVariant; out pszName: WideString): HResult; stdcall;
    function Get_accValue(varChild: OleVariant; out pszValue: WideString): HResult; stdcall;
    function Get_accDescription(varChild: OleVariant; out pszDescription: WideString): HResult; stdcall;
    function Get_accRole(varChild: OleVariant; out pvarRole: OleVariant): HResult; stdcall;
    function Get_accState(varChild: OleVariant; out pvarState: OleVariant): HResult; stdcall;
    function Get_accHelp(varChild: OleVariant; out pszHelp: WideString): HResult; stdcall;
    function Get_accHelpTopic(out pszHelpFile: WideString; varChild: OleVariant; out pidTopic: Integer): HResult; stdcall;
    function Get_accKeyboardShortcut(varChild: OleVariant; out pszKeyboardShortcut: WideString): HResult; stdcall;
    function Get_accFocus(out pvarChild: OleVariant): HResult; stdcall;
    function Get_accSelection(out pvarChildren: OleVariant): HResult; stdcall;
    function Get_accDefaultAction(varChild: OleVariant; out pszDefaultAction: WideString): HResult; stdcall;
    function accSelect(flagsSelect: Integer; varChild: OleVariant): HResult; stdcall;
    function accLocation(out pxLeft: Integer; out pyTop: Integer; out pcxWidth: Integer; out pcyHeight: Integer; varChild: OleVariant): HResult; stdcall;
    function accNavigate(navDir: Integer; varStart: OleVariant; out pvarEndUpAt: OleVariant): HResult; stdcall;
    function accHitTest(xLeft: Integer; yTop: Integer; out pvarChild: OleVariant): HResult; stdcall;
    function accDoDefaultAction(varChild: OleVariant): HResult; stdcall;
    function Set_accName(varChild: OleVariant; const pszName: WideString): HResult; stdcall;
    function Set_accValue(varChild: OleVariant; const pszValue: WideString): HResult; stdcall;
  end;

constructor TMyAccessibleEdit.Create(aEdit: TEdit; aDefAcc: IAccessible);
begin
  inherited Create;
  fEdit := aEdit;
  fDefAcc := aDefAcc;
end;

function TMyAccessibleEdit.QueryInterface(const IID: TGUID; out Obj): HResult; virtual; stdcall;
begin
  if IID = IID_IAccessible then
    Result := inherited QueryInterface(IID, Obj)
  else
    Result := fDefAcc.QueryInterface(IID, Obj);
end;

function TMyAccessibleEdit.GetTypeInfoCount(out Count: Integer): HResult; stdcall;
begin
  Result := fDefAcc.GetTypeInfoCount(Count);
end;

function TMyAccessibleEdit.GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall;
begin
  Result := fDefAcc.GetTypeInfo(Index, LocaleID, TypeInfo);
end;

function TMyAccessibleEdit.GetIDsOfNames(const IID: TGUID; Names: Pointer; NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall;
begin
  Result := fDefAcc.GetIDsOfNames(IID, Names, NameCount, LocaleID, DispIDs);
end;

function TMyAccessibleEdit.Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall;
begin
  Result := fDefAcc.Invoke(DispID, IID, LocaleID, Flags, Params, VarResult, ExcepInfo, ArgErr);
end;

function TMyAccessibleEdit.Get_accParent(out ppdispParent: IDispatch): HResult; stdcall;
begin
  Result := fDefAcc.Get_accParent(ppdispParent);
end;

function TMyAccessibleEdit.Get_accChildCount(out pcountChildren: Integer): HResult; stdcall;
begin
  Result := fDefAcc.Get_accChildCount(pcountChildren);
end;

function TMyAccessibleEdit.Get_accChild(varChild: OleVariant; out ppdispChild: IDispatch): HResult; stdcall;
begin
  Result := fDefAcc.Get_accChild(varChild, ppdispChild);
end;

function TMyAccessibleEdit.Get_accName(varChild: OleVariant; out pszName: WideString): HResult; stdcall;
begin
  Result := fDefAcc.Get_accName(varChild, pszName);
  if (Result = S_OK) and (pszName <> '') then Exit;
  if Integer(varChild) = CHILDID_SELF then begin
    pszName := fEdit.Name;
    Result := S_OK;
  end else
    Result := S_FALSE;
end;

function TMyAccessibleEdit.Get_accValue(varChild: OleVariant; out pszValue: WideString): HResult; stdcall;
begin
  Result := fDefAcc.Get_accValue(varChild, pszValue);
end;

function TMyAccessibleEdit.Get_accDescription(varChild: OleVariant; out pszDescription: WideString): HResult; stdcall;
begin
  Result := fDefAcc.Get_accDescription(varChild, pszDescription);
  if (Result = S_OK) and (pszDescription <> '') then Exit;
  if Integer(varChild) = CHILDID_SELF then begin
    pszDescription := fEdit.Hint;
    Result := S_OK;
  end else
    Result := S_FALSE;
end;

function TMyAccessibleEdit.Get_accRole(varChild: OleVariant; out pvarRole: OleVariant): HResult; stdcall;
begin
  Result := fDefAcc.Get_accRole(varChild, pvarRole);
end;

function TMyAccessibleEdit.Get_accState(varChild: OleVariant; out pvarState: OleVariant): HResult; stdcall;
begin
  Result := fDefAcc.Get_accState(varChild, pvarState);
end;

function TMyAccessibleEdit.Get_accHelp(varChild: OleVariant; out pszHelp: WideString): HResult; stdcall;
begin
  Result := fDefAcc.Get_accHelp(varChild, pszHelp);
end;

function TMyAccessibleEdit.Get_accHelpTopic(out pszHelpFile: WideString; varChild: OleVariant; out pidTopic: Integer): HResult; stdcall;
begin
  Result := fDefAcc.Get_accHelpTopic(pszHelpFile, varChild, pidTopic);
end;

function TMyAccessibleEdit.Get_accKeyboardShortcut(varChild: OleVariant; out pszKeyboardShortcut: WideString): HResult; stdcall;
begin
  Result := fDefAcc.Get_accKeyboardShortcut(varChild, pszKeyboardShortcut);
end;

function TMyAccessibleEdit.Get_accFocus(out pvarChild: OleVariant): HResult; stdcall;
begin
  Result := fDefAcc.Get_accFocus(pvarChild);
end;

function TMyAccessibleEdit.Get_accSelection(out pvarChildren: OleVariant): HResult; stdcall;
begin
  Result := fDefAcc.Get_accSelection(pvarChildren);
end;

function TMyAccessibleEdit.Get_accDefaultAction(varChild: OleVariant; out pszDefaultAction: WideString): HResult; stdcall;
begin
  Result := fDefAcc.Get_accDefaultAction(varChild, pszDefaultAction);
end;

function TMyAccessibleEdit.accSelect(flagsSelect: Integer; varChild: OleVariant): HResult; stdcall;
begin
  Result := fDefAcc.accSelect(flagsSelect, varChild);
end;

function TMyAccessibleEdit.accLocation(out pxLeft: Integer; out pyTop: Integer; out pcxWidth: Integer; out pcyHeight: Integer; varChild: OleVariant): HResult; stdcall;
 begin
  Result := fDefAcc.accLocation(pxLeft, pyTop, pcxWidth, pcyHeight, varChild);
end;

function TMyAccessibleEdit.accNavigate(navDir: Integer; varStart: OleVariant; out pvarEndUpAt: OleVariant): HResult; stdcall;
begin
  Result := fDefAcc.accNavigate(navDir, varStart, pvarEndUpAt);
end;

function TMyAccessibleEdit.accHitTest(xLeft: Integer; yTop: Integer; out pvarChild: OleVariant): HResult; stdcall;
begin
  Result := fDefAcc.accHitTest(xLeft, yTop, pvarChild);
end;

function TMyAccessibleEdit.accDoDefaultAction(varChild: OleVariant): HResult; stdcall;
begin
  Result := fDefAcc.accDoDefaultAction(varChild);
end;

function TMyAccessibleEdit.Set_accName(varChild: OleVariant; const pszName: WideString): HResult; stdcall;
begin
  Result := fDefAcc.Set_accName(varChild, pszName);
end;

function TMyAccessibleEdit.Set_accValue(varChild: OleVariant; const pszValue: WideString): HResult; stdcall;
begin
  Result := fDefAcc.Set_accValue(varChild, pszValue);
end;

type
  TMyForm = class(TForm)
    procedure FormCreate(Sender: TObject);
    ...
  private
    DefEditWndProc: TWndMethod;
    procedure EditWndProc(var Message: TMessage);
    ...
  end;

procedure TMyForm.FormCreate(Sender: TObject);
begin
  DefEditWndProc := Edit1.WindowProc;
  Edit1.WindowProc := EditWndProc;
end;

procedure TMyForm.EditWndProc(var Message: TMessage);
var
  DefAcc, MyAcc: IAccessible;
  Ret: LRESULT;
begin
  DefEditWndProc(Message);
  if (Message.Msg = WM_GETOBJECT) and (DWORD(Message.LParam) = OBJID_CLIENT) and (Message.Result > 0) then
  begin
    if ObjectFromLresult(Message.Result, IAccessible, Message.WParam, DefAcc) = S_OK then
    begin
      MyAcc := TMyAccessibleEdit.Create(Edit1, DefAcc) as IAccessible;
      Message.Result := LresultFromObject(IAccessible, Message.WParam, MyAcc);
    end;
  end;
end;

Effulgent

Remy, Thank you for the quick reply. I was able to get the accessible properties for my control with your help. – Jylland

Remy, did you construct a complete project to test this? If so, can you use ReportMemoryLeaksOnShutdown? I'm having issues with the instance that implements IAccessible never being released, I'm guessing because the reference count never reaches zero – Tyche

OK, I've discovered this is an issue when using Narrator (MS's built-in screen-reader). The issue apparently does not present itself with JAWS, for example – Tyche

No, I had not tested the code. If there was a memory leak, I was not aware of that. On the other hand, Ostendo's answer implements IAccessible directly in a TEdit descendant, and TComponent disables reference counting for implemented interfaces. – Effulgent

It appears the leak is being caused by Narrator itself: social.technet.microsoft.com/Forums/windows/en-US/… Still, it would be helpful if there was a way around this, as we hope to support at least Narrator and JAWS – Tyche

In my example, I create a new IAccessible object on every WM_GETOBJECT message, expecting the message sender to release it. That is typical COM usage. However, to work around Narrator's leaks, you will likely have to make WM_GETOBJECT return a singleton object every time. Either disable its reference counting, or keep your own reference to it. Narrator can then leak as much as it wants, there will only be one object in memory, and it will still behave correctly for well-behaved clients like JAWS. For that scenario, I would lean towards Ostendo's implementation. – Effulgent