在 Delphi 中创建可访问的 UI 组件

我正在尝试从标准 VCL TEdit 控件检索可访问的信息。 get_accName() 和 Get_accDescription() 方法返回空字符串，但 get_accValue() 返回输入到 TEdit 中的文本值。

我刚刚开始尝试理解 MSAA，但此时我有点迷失。

我的 TEdit 是否需要具有向 MSA 公开的其他已发布属性？如果是这样，是否需要创建一个源自 TEdit 的新组件并添加其他已发布的属性，例如“AccessibleName”、“AccessibleDescription”等...？

另外，请注意，我查看了 VTVirtualTrees 组件，它是supposed可以访问，但即使在该控件上，MS Active Accessibility 对象检查器仍然看不到 AccessibleName 已发布属性。

在这一点上，我很茫然，非常感谢您在这件事上的任何建议或帮助。

...
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.

VCL 本身并不原生实现对 MSAA 的任何支持。 Windows 提供了标准 UI 控件的默认实现，许多标准 VCL 组件都封装了这些控件。如果您需要比 Windows 提供的更多 MSAA 支持，则必须实施IAccessible http://msdn.microsoft.com/en-us/library/windows/desktop/dd318466.aspx自己连接，然后让你的控件响应WM_GETOBJECT http://msdn.microsoft.com/en-us/library/windows/desktop/dd373894.aspx消息，以便它可以返回指向您的实现实例的指针。

Update:例如，将 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 (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;