creating accessible ui components in delphi

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.

 

 

출처: http://stackoverflow.com/questions/16320914/creating-accessible-ui-components-in-delphi