Создание доступных компонентов пользовательского интерфейса в Delphi

Ответ 1

Мне удалось выполнить эту работу через

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.

Ответ 2

Сам VCL не поддерживает какую-либо поддержку MSAA. Windows предоставляет стандартные реализации для стандартных элементов управления пользовательского интерфейса, которые переносят многие стандартные компоненты VCL. Если вам нужна дополнительная поддержка MSAA, чем Windows, вам нужно будет реализовать интерфейс IAccessible, а затем отредактировать свой элемент управления WM_GETOBJECT, чтобы он мог вернуть указатель на экземпляр вашей реализации.

Обновление: Например, один из способов добавления MSAA в существующий TEdit (если вы не хотите получать свой собственный компонент) может выглядеть примерно так:

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 (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;