TVarData(varChild).VType    := varInteger;
     TVarData(varChild).VInteger := SpinEdit1.Value;
     oAccessible.accDoDefaultAction(varChild);

     TVariantArg(varChild).vt   := VT_I4;
     TVariantArg(varChild).lVal := SpinEdit1.Value;
     oAccessible.accDoDefaultAction(varChild);

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, Spin, ExtCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    SpinEdit1: TSpinEdit;
    Panel1: TPanel;
    procedure Button1Click(Sender: TObject);
  private
    { Private 宣言 }
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses oleacc, ActiveX;

{$R *.dfm}

var
  TargetClassName : String;

//-----------------------------------------------------------------------------
//  ウィンドウのクラス名を取得する関数
//-----------------------------------------------------------------------------
function GetWindowClassNameStr(hWindow: HWND): String;
var
  Buffer : array[0..MAX_PATH-1] of Char;
  Len    : Integer;
begin
  FillChar(Buffer, SizeOf(Buffer), #0);
  Len := GetClassName(hWindow, Buffer, Length(Buffer));
  if Len > 0 then begin
    Result := Buffer;
  end else begin
    Result := '';
  end;
end;

//-----------------------------------------------------------------------------
//  EnumWindowsのコールバック関数
//  指定したウィンドウクラスのウィンドウを検索する
//-----------------------------------------------------------------------------
function EnumWindowProc(hWindow: HWND; lPalam: PNativeInt): Boolean; stdcall;
begin
  Result := True;

  if IsWindowVisible(hWindow) then begin
    if Pos(TargetClassName, GetWindowClassNameStr(hWindow)) > 0 then begin
      lPalam^ := hWindow;
      Result  := False;
    end;
  end;
end;

//=============================================================================
//  [toolStrip]のボタンをクリック
//  toolStripは.NET Framework(C#)用のコントロール
//  添付の操作対象アプリはC#で(.NET Framework 4 Client Profile)作成したもの
//
//  usesに oleacc, ActiveXが必要
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  hTargetWnd  : HWND;
  hToolStrip  : HWND;
  oAccessible : IAccessible;
  varChild    : OleVariant;
  vValue      : OleVariant;
  StrText     : WideString;
begin
  //トップレベルのウィンドウからクラス名の一部が一致するウィンドウを検索
  TargetClassName := 'WindowsForms10.Window.8.app';
  hTargetWnd      := 0;
  EnumWindows(@EnumWindowProc, LPARAM(@hTargetWnd));
  //toolStripのハンドルを取得
  hToolStrip := FindWindowEx(hTargetWnd, 0, nil, 'toolStrip1');

  if hToolStrip = 0 then begin
    MessageDlg('操作対象コントロールが見つかりません', mtInformation, [mbOK], 0);
    exit;
  end;

  Panel1.Caption := '';
  //そのハンドルのIAccessibleオブジェクトを取得
  if AccessibleObjectFromWindow(hToolStrip,
                                OBJID_CLIENT,
                                IID_IAccessible,
                                oAccessible) = S_OK then begin

     //SpinEditの値と同じ番号のtoolStripオブジェクトのデフォルト動作を実行
     //オブジェクトの全てがボタンとは限らないので注意
     TVariantArg(varChild).vt   := VT_I4;
     TVariantArg(varChild).lVal := SpinEdit1.Value;
     oAccessible.accDoDefaultAction(varChild);

     //ついでにNameプロパティを取得して表示してみる
     oAccessible.Get_accName(varChild, StrText);
     Panel1.Caption := StrText;
  end;
  varChild := Unassigned;
  vValue   := Unassigned;
end;

end.

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ExtCtrls, StdCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Memo1: TMemo;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

uses OleAcc, ActiveX;

{$R *.dfm}

//=============================================================================
//  [取得]ボタンクリック
//  他のアプリのTStatusbarのテキストを取得して表示
//
//  usesにOleAcc, ActiveXが必要
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  hTargetForm : HWND;
  hStatusbar  : HWND;
  oAccessible : IAccessible;
  ChildCount  : Integer;
  i           : Integer;
  varChild    : OleVariant;
  StrText     : WideString;
begin
  Memo1.Lines.Clear;

  //対象のStatusbarのハンドルを取得
  hTargetForm := FindWindow('TTargetForm', nil);
  hStatusbar  := FindWindowEx(hTargetForm, 0, 'TStatusbar', nil);

  if hStatusbar = 0 then begin
    MessageDlg('操作対象アプリが見つかりません', mtInformation, [mbOK], 0);
    exit;
  end;

  //そのハンドルのIAccessibleオブジェクトを取得
  if AccessibleObjectFromWindow(hStatusbar,
                                OBJID_CLIENT,
                                IID_IAccessible,
                                oAccessible) = S_OK then begin
    //その子オブジェクトの数を調査
    //本来は，AccessibleChildren関数で操作可能を調査すべきだが，ここでは間違い
    //なく操作可能であると判断
    oAccessible.Get_accChildCount(ChildCount);

    //オブジェクトの数だけテキストを取得
    TVariantArg(varChild).vt := VT_I4;
    for i := 1 to ChildCount do begin
      TVariantArg(varChild).lVal := i;
      oAccessible.Get_accName(varChild, StrText);
      Memo1.Lines.Add(StrText);
    end;
  end;
  varChild := Unassigned;
end;

end.

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ExtCtrls, StdCtrls, OleAcc;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    Button3: TButton;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

uses
  plSearchIAccObjName;

{$R *.dfm}

//対象のウィンドウの情報を格納するレコード型の定義
type
  TTargetWndInfo = record
    hWindow   : HWND;
    ClassName : String;
  end;
  PTargetWndInfo = ^TTargetWndInfo;


//-----------------------------------------------------------------------------
//  EnumWindowsのコールバック関数
//  可視で他に所有されていないトップレベルのウィンドウだけを検出
//  PTargetWndInfoはウィンドウの情報を格納するレコード型のポインタ
//-----------------------------------------------------------------------------
function EnumVisbleNoOwnedWndProc(hWindow: HWND; lData: PTargetWndInfo): BOOL; stdcall;

  //---------------------------------------------------------------------------
  //  引数のウィンドウがオーナーウィンドウであるかを調査
  //---------------------------------------------------------------------------
  function IsOwnedWindow(hWindow: HWND): Boolean;
  begin
    Result := Windows.GetWindow(hWindow, GW_OWNER) <> 0;
  end;

  //-----------------------------------------------------------------------------
  //  ウィンドウハンドルからウィンドウクラス名を取得
  //-----------------------------------------------------------------------------
  function GetClassNameStr(hWindow: HWND): string;
  var
    Buffer : array[0..MAX_PATH-1] of Char;
    Len    : Integer;
  begin
    FillChar(Buffer, SizeOf(Buffer), #0);
    Len := GetClassName(hWindow, Buffer, Length(Buffer));
    if Len > 0 then Result := Buffer else Result := '';
  end;
  //-----------------------------------------------------------------------------

var
  LClassName : String;
begin
  Result := True;
  if IsOwnedWindow(hWindow) then exit;
  if not Windows.IsWindowVisible(hWindow) then exit;

  //クラス名が同じだったら，そのウィンドウハンドルをコールバックの引数に返す
  LClassName := UpperCase(GetClassNameStr(hWindow));
  if LClassName = UpperCase(lData^.ClassName) then begin
    lData^.hWindow := hWindow;
    Result := False;
  end;
end;

//=============================================================================
//  [戻る]ボタンクリック
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  LWndInfo   : TTargetWndInfo;
  LTargetWnd : HWND;
  LBackAcc   : IAccessible;
  LChildID   : Integer;
begin
  //Firefoxのハンドルを取得
  LWndInfo.ClassName := 'MozillaWindowClass';
  LWndInfo.hWindow   := 0;
  //指定クラス名のウィンドウを検索
  EnumWindows(@EnumVisbleNoOwnedWndProc, LPARAM(@LWndInfo));
  LTargetWnd := LWndInfo.hWindow;

  if LTargetWnd = 0 then begin
    MessageDlg('Fire Foxが見つかりません', mtInformation, [mbOK], 0);
  end else begin
    //[戻る]ボタンのIAccessibleオブジェクトを取得
    if LBackAcc = nil then begin
      LBackAcc := SearchAccObjectFromWindow(LTargetWnd, '戻る', LChildID);
    end;

    if LBackAcc = nil then begin
      MessageDlg('操作できません', mtInformation, [mbOK], 0);
    end else begin
      //[戻る]ボタンのデフォルト動作を実行
      LBackAcc.accDoDefaultAction(LChildID);
    end;
  end;
end;

//=============================================================================
//  [進む]ボタンクリック
//=============================================================================
procedure TForm1.Button2Click(Sender: TObject);
var
  LWndInfo     : TTargetWndInfo;
  LTargetWnd   : HWND;
  LForewordAcc : IAccessible;
  LChildID     : Integer;
begin
  //Firefoxのハンドルを取得
  LWndInfo.ClassName := 'MozillaWindowClass';
  LWndInfo.hWindow   := 0;
  //指定クラス名のウィンドウを検索
  EnumWindows(@EnumVisbleNoOwnedWndProc, LPARAM(@LWndInfo));
  LTargetWnd := LWndInfo.hWindow;

  if LTargetWnd = 0 then begin
    MessageDlg('Fire Foxが見つかりません', mtInformation, [mbOK], 0);
  end else begin
    if LForewordAcc = nil then begin
      LForewordAcc := SearchAccObjectFromWindow(LTargetWnd, '進む', LChildID);
    end;

    //[進む]ボタンのIAccessibleオブジェクトを取得
    if LForewordAcc = nil then begin
      MessageDlg('操作できません', mtInformation, [mbOK], 0);
    end else begin
      //[進む]ボタンのデフォルト動作を実行
      LForewordAcc.accDoDefaultAction(LChildID);
    end;
  end;
end;

//=============================================================================
//  [閉じる]ボタンクリック
//
//  Windows XP(SP3) + Firefox 12.0 では動作する
//  Windows 7 U64(SP1) + Firefox 12.0 てば動作しない
//=============================================================================
procedure TForm1.Button3Click(Sender: TObject);
var
  LWndInfo   : TTargetWndInfo;
  LTargetWnd : HWND;
  LCloseAcc  : IAccessible;
  LChildID   : Integer;
begin
  //Firefoxのハンドルを取得
  LWndInfo.ClassName := 'MozillaWindowClass';
  LWndInfo.hWindow   := 0;
  //指定クラス名のウィンドウを検索
  EnumWindows(@EnumVisbleNoOwnedWndProc, LPARAM(@LWndInfo));
  LTargetWnd := LWndInfo.hWindow;

  if LTargetWnd = 0 then begin
    MessageDlg('Fire Foxが見つかりません', mtInformation, [mbOK], 0);
  end else begin
    if LCloseAcc = nil then begin
      LCloseAcc := SearchAccObjectFromWindow(LTargetWnd, '閉じる', LChildID);
    end;

    //[閉じる]ボタンのIAccessibleオブジェクトを取得
    if LCloseAcc = nil then begin
      MessageDlg('操作できません', mtInformation, [mbOK], 0);
    end else begin
      //[閉じる]ボタンのデフォルト動作を実行
      LCloseAcc.accDoDefaultAction(LChildID);
    end;
  end;
end;

end.

unit plSearchIAccObjName;

interface

uses
  Windows, SysUtils, Forms, ActiveX, OleAcc, Variants;

  function SearchAccObjectFromWindow(Wnd: HWND; SearchName: String;
    var ChildID: Integer): IAccessible;
  function SearchAccChild(Acc: IAccessible; SearchName: String;
    var ID: Integer): IAccessible;

  //Delphi XEにないので定義
  function AccessibleChildren(paccContainer: IAccessible; iChildStart,
    cChildren: Longint; rgvarChildren: PVariantArg;
    pcObtained: PLongint): HRESULT; stdcall; external 'oleacc.dll';

implementation

//=============================================================================
//  引数で指定するウィンドウ階層下のオブジェクトから，指定Nameプロパティを持つ
//  オブジェクトを検索して返す関数
//  ただし，非表示のオブジェクトを除く
//
//  Wnd        : 検索対象ウィンドウのハンドル
//  SearchName : 検索文字列
//  ChildID    : 検索したオブジェクトの子オブジェクト番号(1,2,3, ...)
//               0の時は，戻り値は検索結果のオブジェクトのIAccessible
//               1以外の時の戻り値は，検索結果の直接の親のオブジェクト
//  戻り値は，検索結果のオブジェクトの直接の親のIAccessible
//  見つからなかった時はnilを返す
//
//  この関数の呼び出し側では，戻り値とChildIDの値でオブジェクトを操作する
//=============================================================================
function SearchAccObjectFromWindow(Wnd: HWND; SearchName: String;
  var ChildID: Integer): IAccessible;
var
  oAccessible : IAccessible;
begin
  Result := nil;

  //WndのIAccessibleオブジェクトを取得
  if AccessibleObjectFromWindow(
      Wnd,
      OBJID_WINDOW,
      IID_IAccessible,
      Pointer(oAccessible)) = S_OK then begin
    Result := SearchAccchild(oAccessible, SearchName, ChildID);
  end;
end;

//-----------------------------------------------------------------------------
//  検索対象の文字列かを検査する関数
//  非可視のオブジェクトは除外
//-----------------------------------------------------------------------------
function IsSearchName(AccChild: IAccessible; ChildID: Integer;
  SearchName: String): Boolean;
var
  varState : OleVariant;
  VState   : Cardinal;
  varChild : OleVariant;
  AccName  : WideString;
begin
  Result := False;

  TVariantArg(varChild).vt   := VT_I4;
  TVariantArg(varChild).lVal := ChildID;

  if AccChild.Get_accState(varChild, varState) = S_OK then begin
    if TVariantArg(varState).vt = VT_I4 then begin
      VState :=  TVariantArg(varState).lVal;
      if (VState and STATE_SYSTEM_INVISIBLE) = 0 then begin
        if AccChild.get_accName(varChild, AccName) = S_OK then begin
          Result := UpperCase(Trim(AccName)) = UpperCase(SearchName);
        end;
      end;
    end;
  end;
end;

//=============================================================================
//  引数で指定するIAccessibleオブジェクト階層下から，指定のNameプロパティを持つ
//  オブジェクトを検索して返す関数
//  ただし，非表示のオブジェクトを除く
//  この関数を再帰的に実行し，オブジェクトの階層下を検索していく
//
//  Acc        : 検索対象のIAccessibleオブジェクト
//  SearchName : 検索文字列
//  ID         : 検索したオブジェクトの子オブジェクト番号(1,2,3, ...)
//               0の時は，戻り値は検索結果のオブジェクトのIAccessible
//               1以外の時の戻り値は，検索結果の直接の親のオブジェクト
//  戻り値は，検索結果のオブジェクトの直接の親のIAccessible
//  見つからなかった時はnilを返す
//
//  この関数の呼び出し側では，戻り値とChildIDの値でオブジェクトを操作する
//=============================================================================
function SearchAccChild(Acc: IAccessible; SearchName: String;
  var ID: Integer): IAccessible;
var
  Children   : array of TVariantArg;
  ChildCount : Integer;
  Obtained   : Integer;
  AccChDisp  : IDispatch;
  AccChild   : IAccessible;
  ChildID    : Integer;
  i          : Integer;
  j          : Integer;
  HasChild   : Integer;
begin
  Result := nil;
  if Acc = nil then exit;

  //子オブジェクトの数を調べる
  if Acc.get_accChildCount(ChildCount) = S_OK then begin
    Application.ProcessMessages;
    SetLength(Children, ChildCount);

    //バリアント配列の初期化
    for i := 0 to ChildCount - 1 do begin
      VariantInit(OleVariant(Children[i]));
    end;

    //アクセス可能なオブジェクトの数を調査
    if AccessibleChildren(Acc, 0, ChildCount, @Children[0], @Obtained) = S_OK
        then begin
      for j := 0 to Obtained - 1 do begin
        HasChild := -1;
        ChildID  := CHILDID_SELF;

        //子オブジェクトがある
        if Children[j].vt = VT_DISPATCH then begin
          AccChDisp := IDispatch(Children[j].pdispVal);
          if Assigned(AccChDisp) then begin
            AccChDisp.QueryInterface(IID_IAccessible, AccChild);
            ChildID  := CHILDID_SELF;
            HasChild := 1;
          end;
        end else begin
          if Children[j].vt = VT_I4 then begin
            //子オブジェクトはない
            if Acc.get_accChild(OleVariant(Children[j]), AccChDisp) = S_FALSE
                then begin
              AccChild := Acc;
              ChildID  := Children[j].lVal;
              HasChild := 0;
            end else begin
               //子オブジェクトがある
              if Assigned(AccChDisp) then begin
                AccChDisp.QueryInterface(IID_IAccessible, AccChild);
                ChildID  := CHILDID_SELF;
                HasChild := 1;
              end;
            end;
          end;
        end;

        //処理を1か所にまとめるためにHasChildをフラグとして使用
        if HasChild >= 0 then begin
          if IsSearchName(AccChild, ChildID, SearchName) then begin
            ID     := ChildID;
            Result := AccChild;
            break;
          end;
          if (HasChild = 1) then begin
            Result := SearchAccChild(AccChild, SearchName, ID);
            if Result <> nil then Break;
          end;
        end;
      end;
    end;
    //バリアント配列の後始末
    for i := 0 to Obtained - 1 do begin
      VariantClear(OleVariant(Children[i]));
    end;
  end;
end;

end.

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, oleacc, ExtCtrls, ComCtrls, ActiveX, Menus,
  plWindowRectFormUnit, Buttons;

type
  TForm1 = class(TForm)
    TreeView1: TTreeView;
    Panel1: TPanel;
    Button2: TButton;
    Splitter1: TSplitter;
    Panel2: TPanel;
    ListView1: TListView;
    Button1: TButton;
    RadioGroup1: TRadioGroup;
    Memo1: TMemo;
    PopupMenu1: TPopupMenu;
    N1: TMenuItem;
    Panel3: TPanel;
    Button3: TButton;
    PopupMenu2: TPopupMenu;
    N2: TMenuItem;
    SpeedButton1: TSpeedButton;
    SpeedButton2: TSpeedButton;
    procedure TreeView1Deletion(Sender: TObject; Node: TTreeNode);
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
    procedure N1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure ListView1SelectItem(Sender: TObject; Item: TListItem;
      Selected: Boolean);
    procedure RadioGroup1Click(Sender: TObject);
    procedure N2Click(Sender: TObject);
    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
    procedure SpeedButton1Click(Sender: TObject);
    procedure SpeedButton2Click(Sender: TObject);
    procedure TreeView1Change(Sender: TObject; Node: TTreeNode);
  private
    { Private 宣言 }
    hTargetWnd       : HWND;
    TargetClassName  : String;
    RectForm         : TplWindowRectForm;
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses plEnumAccInfos, WindowTreeUnit, Clipbrd;

{$R *.dfm}

//=============================================================================
//  フォーム生成時の処理
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
begin
  ListView1.PopupMenu := nil;
  TreeView1.PopupMenu := nil;
end;

//=============================================================================
//  フォームを閉じる時の処理
//=============================================================================
procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
  if Assigned(RectForm) then begin
    RectForm.Close;
    FreeAndNil(RectForm);
  end;
end;

//=============================================================================
//  [ウィンドウ選択]ボタン
//  ウィンドウのリスト表示用のフォームをモーダル表示して選択
//
//  hTargetWnd      : 対象のウィンドウのハンドル
//  TargetClassName : 対象のウィンドウのクラス名
//  は，モーダル表示したフォームから取得する
//  共にグローバル変数
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  AForm : TWindowTreeForm;
  dwID  : Cardinal;
  Ret   : Integer;
begin
  if Assigned(RectForm) then begin
    RectForm.Close;
    FreeAndNil(RectForm);
  end;
  TreeView1.PopupMenu := nil;
  ListView1.PopupMenu := nil;

  Ret := mrOk;
  if Sender <> nil then begin
    AForm := TWindowTreeForm.Create(Self);
    try
      Ret := AForm.ShowModal;
      if Ret = mrOk then begin
        Self.Update;
        hTargetWnd       := AForm.hTargetWnd;
        TargetClassName  := AForm.TargetClassName;
      end;
    finally
      FreeAndNil(AForm);
    end;
  end;

  if Ret = mrOk then begin
    Screen.Cursor := crHourGlass;

    TreeView1.Items.Clear;
    ListView1.Items.Clear;
    Memo1.Lines.Clear;

    dwID := OBJID_CLIENT;
    if RadioGroup1.ItemIndex = 0 then dwID := OBJID_WINDOW;
    if RadioGroup1.ItemIndex = 1 then dwID := OBJID_CLIENT;
    plEnumAccInfos.EnumAccObjectTree(hTargetWnd, TreeView1, dwID);

    Screen.Cursor := crDefault;
  end;
end;

//=============================================================================
//  [ツリー更新]ボタン
//  オブジェクトの再取得
//  ボップアップメニューの[このオブジェクトをルートにして再取得]と同じコードを実行
//  ただし，このオブジェクトは，トップノードのものとする
//=============================================================================
procedure TForm1.Button2Click(Sender: TObject);
begin
  if Assigned(RectForm) then begin
    RectForm.Close;
    FreeAndNil(RectForm);
  end;

  if TreeView1.Items.Count > 1 then begin
    N2Click(nil);
  end;
end;

//=============================================================================
//  [全て展開]ボタン
//=============================================================================
procedure TForm1.Button3Click(Sender: TObject);
begin
  if Assigned(RectForm) then begin
    RectForm.Close;
    FreeAndNil(RectForm);
  end;

  if TreeView1.Items.Count = 0 then exit;

  TreeView1.Items.BeginUpdate;
  TreeView1.FullExpand;
  TreeView1.TopItem := TreeView1.Items[0];
  TreeView1.Items.EndUpdate;
end;

//=============================================================================
//  RadioGroup1のOnClickイベント
//  [ウィンドウ選択]ボタンと同じコードを実行
//=============================================================================
procedure TForm1.RadioGroup1Click(Sender: TObject);
begin
  Button1Click(nil);
end;

//=============================================================================
//  [デフォルトアクション実行]ボタン
//  オブジェクトのデフォルト動作を実行
//  全てのオブジェクトに対して有効なわけではない
//=============================================================================
procedure TForm1.SpeedButton1Click(Sender: TObject);
var
  pAccInfo : PplAccInfoRec;
  Acc      : IAccessible;
  ChildID  : Integer;
  varChild : OleVariant;
begin
  if TreeView1.Selected = nil then exit;

  //NodeのDataプロパティからオブジェクトのデータを取出す
  //このデータはレコード型に格納されている
  pAccInfo := TreeView1.Selected.Data;
  Acc      := pAccInfo.pAcc;
  ChildID  := pAccInfo.ChildID;

  TVariantArg(varChild).vt   := VT_I4;
  TVariantArg(varChild).lVal := ChildID;

  Acc.accDoDefaultAction(varChild);
end;

//=============================================================================
//  [値のセット]ボタン
//  オブジェクトに対してput_accValue(DelphiではSet_accValue)メソッドを実行
//  オブジェクトに値をセットする．編集可能なオブジェクトが対象
//  全てのオブジェクトに対して有効なわけではない
//=============================================================================
procedure TForm1.SpeedButton2Click(Sender: TObject);
var
  pAccInfo : PplAccInfoRec;
  Acc      : IAccessible;
  ChildID  : Integer;
  StrSet   : WideString;
  varChild : OleVariant;
begin
  if TreeView1.Selected = nil then exit;

  //NodeのDataプロパティからオブジェクトのデータを取出す
  //このデータはレコード型に格納されている
  pAccInfo := TreeView1.Selected.Data;
  Acc      := pAccInfo.pAcc;
  ChildID  := pAccInfo.ChildID;

  //Memo1に入力した値を使用
  StrSet := Memo1.Text;
  TVariantArg(varChild).vt   := VT_I4;
  TVariantArg(varChild).lVal := ChildID;

  Acc.Set_accValue(varChild, StrSet);
end;

//=============================================================================
//  TreeView1のOnChangeイベント処理
//
//  TreeView1の選択ノードが変更になったら，プロパティを取得して表示
//=============================================================================
procedure TForm1.TreeView1Change(Sender: TObject; Node: TTreeNode);
var
  pAccInfo   : PplAccInfoRec;
  Acc        : IAccessible;
  ChildID    : Integer;
  StrText    : WideString;
  varChild   : OleVariant;
  RectWnd    : TRect;
  LineWidth  : Integer;
  LineColor  : TColor;
  ShowFlag   : Cardinal;
begin
  if Node = nil then begin
    TreeView1.PopupMenu := nil;
    exit;
  end else begin
    TreeView1.PopupMenu := PopupMenu2;
  end;

  if not Assigned(RectForm) then begin
    RectForm := TplWindowRectForm.Create(Self);
    RectForm.Show;
    TreeView1.SetFocus;
  end else begin
    RectForm.Canvas.FillRect(RectForm.ClientRect);
  end;
  ShowFlag := SWP_NOACTIVATE or SWP_NOMOVE or SWP_NOSIZE or SWP_NOOWNERZORDER;
  SetWindowPos(RectForm.Handle, HWND_TOPMOST, 0, 0, 0, 0, ShowFlag);

  //プロパティをListView1に表示するメソッドを実行
  plEnumAccInfos.AccObjectInfo(ListView1, Node);

  //NodeのDataプロパティからオブジェクトのデータを取出す
  //このデータはレコード型で格納されている
  pAccInfo := Node.Data;
  Acc      := pAccInfo.pAcc;
  ChildID  := pAccInfo.ChildID;

  Memo1.Clear;
  //Valueプロパティの値を取得
  StrText := plEnumAccInfos.GetAccObjectValue(Acc, ChildID);

  //Valueプロパティの値が空の時は，Nameプロパティの値を取得
  //複数行の場合があるのでTMemoに表示
  if Trim(StrText) = '' then begin
    TVariantArg(varChild).vt   := VT_I4;
    TVariantArg(varChild).lVal := ChildID;
    if Acc.get_accName(varChild, StrText) = S_OK then begin
      Memo1.Text := StrText;
      Panel3.Caption := 'Name property';
    end;
  end else begin
    Memo1.Text := StrText;
    Panel3.Caption := 'Value property';
  end;;


  //TreeViewで選択したNodeに該当するオブジェクト囲む枠線を表示
  //サイズと位置を取得
  RectWnd   := plEnumAccInfos.GetAccObjectRect(Acc, ChildID);
  LineWidth := 4;
  LineColor := clRed;

  //枠線を描画
  with RectForm.Canvas do begin
    Pen.Color := LineColor;
    Pen.Width := LineWidth;

    MoveTo (RectWnd.Left,  RectWnd.Top);
    LineTo (RectWnd.Right, RectWnd.Top);
    LineTo (RectWnd.Right, RectWnd.Bottom);
    LineTo (RectWnd.Left,  RectWnd.Bottom);
    LineTo (RectWnd.Left,  RectWnd.Top);
  end;
  Sleep(1);
end;

//=============================================================================
//  TreeView1のOnDeletionイベント処理
//
//  TreeViewのDataプロパティのデータを解放
//=============================================================================
procedure TForm1.TreeView1Deletion(Sender: TObject; Node: TTreeNode);
begin
  if Assigned(Node.Data) then begin
    Dispose(PplAccInfoRec(Node.Data));
    Node.Data := nil;
  end;
end;

//=============================================================================
//  ListView1のOnSelectItemイベント処理
//  Itemを選択したら，ポップアップメニューを使用可能にする
//=============================================================================
procedure TForm1.ListView1SelectItem(Sender: TObject; Item: TListItem;
  Selected: Boolean);
begin
  if Selected then begin
    ListView1.PopupMenu := PopupMenu1;
  end else begin
    ListView1.PopupMenu := nil;
  end;
end;

//=============================================================================
//  ListView1のボップアップメニューの[コピー]
//  PopupMenu1のAutoHotkeysとAutoLineReductionプロパティはmaManual
//=============================================================================
procedure TForm1.N1Click(Sender: TObject);
var
  AIndex  : Integer;
  StrText : String;
begin
  AIndex  := ListView1.ItemIndex;
  StrText := ListView1.Items[AIndex].Caption + Char(VK_TAB) +
             ListView1.Items[AIndex].SubItems[0];
  Clipboard.AsText := StrText;
end;

//=============================================================================
//  TreeView1のボップアップメニューの[このオブジェクトをルートにして再取得]
//  オブジェクトのカテゴリー(OBJID_WINDOW,OBJID_CLIENT)は現在の設定を使用
//  ツリー更新にもこのコードを使用する
//
//  PopupMenu2のAutoHotkeysとAutoLineReductionプロパティはmaManual
//=============================================================================
procedure TForm1.N2Click(Sender: TObject);
var
  pAccInfo : PplAccInfoRec;
  Acc      : IAccessible;
  ChildID  : Integer;
  RootNode : TTreeNode;
begin
  if Assigned(RectForm) then begin
    RectForm.Close;
    FreeAndNil(RectForm);
  end;
  TreeView1.PopupMenu := nil;
  ListView1.PopupMenu := nil;

  Screen.Cursor := crHourGlass;
  TreeView1.Items.BeginUpdate;

  //全体の更新の場合
  //ルートノードに該当するオブジェクトとする
  if Sender = nil then begin
    TreeView1.Selected := TreeView1.Items[0];
  end;

  //NodeのDataプロパティからオブジェクトのデータを取出す
  //このデータはレコード型で格納されている
  pAccInfo := TreeView1.Selected.Data;
  Acc      := pAccInfo.pAcc;
  ChildID  := pAccInfo.ChildID;

  TreeView1.Items.Clear;
  ListView1.Items.Clear;
  Memo1.Lines.Clear;

  //ルートノード
  RootNode := plEnumAccInfos.AddChildNode(Acc, ChildID, TreeView1, nil);

  //EnumAccTreeItems関数は，Acc階層下のオブジェクトを列挙するので子オブジェクト
  //がない場合は実行しない
  if (RootNode <> nil) and (ChildID = 0) then begin
    //列挙実行
    plEnumAccInfos.EnumAccTreeItems(Acc, TreeView1, RootNode);
    RootNode.HasChildren := TreeView1.Items.Count > 1;
    TreeView1.TopItem.Expand(False);
  end;
  TreeView1.Items.EndUpdate;
  Screen.Cursor := crDefault;
end;

end.

unit plEnumAccInfos;

interface

uses
  Windows, SysUtils, Forms, ActiveX, OleAcc, Variants, ComCtrls;

type
  //オブジェクトの情報用のレコード型
  //各ノードのDataぷパティに代入する
  TplAccInfoRec = record
    ChildID : Integer;
    pAcc    : IAccessible;
  end;
  PplAccInfoRec = ^TplAccInfoRec;

  //公開関数類
  procedure EnumAccObjectTree(hWindow: HWND; Tree: TTreeView; dwID: Cardinal);
  procedure EnumAccTreeItems(Acc: IAccessible; ATree: TTreeView; ANode: TTreeNode);
  function AddChildNode(AccChild: IAccessible; ChildID: Integer; ATree: TTreeView;
    ANode: TTreeNode): TTreeNode;
  procedure AccObjectInfo(LV : TListView; Node: TTreeNode);
  function GetAccObjectValue(Acc: IAccessible; ChildID: Integer): String;
  function GetAccObjectRect(Acc: IAccessible; ChildID: Integer): TRect;
  function IsAccObjectVisible(Acc: IAccessible; ChildID: Integer): Boolean;

  //以下の関数は，Delphi XEにないので定義
  function WindowFromAccessibleObject(paccContainer: IAccessible; var phwnd: HWND):
    HRESULT;stdcall; external 'oleacc.dll';
  function AccessibleChildren(paccContainer: IAccessible; iChildStart,
    cChildren: Longint; rgvarChildren: PVariantArg;
    pcObtained: PLongint): HRESULT; stdcall; external 'oleacc.dll';
  function AccessibleObjectFromPoint(ptScreen: TPoint; out ppacc: IAccessible;
    out pvarChild): HRESULT; stdcall; external 'oleacc.dll';
  function GetRoleTextW(dwRole: DWORD; lpszRole: PWideChar;
    cchRoleMax: UINT): UINT; stdcall; external 'oleacc.dll';
  function GetStateTextW(dwStateBit: DWORD; lpszStateBit: PWideChar;
    cchStateBitMax: UINT): UINT; stdcall; external 'oleacc.dll';

implementation

var
  //可視状態のオブジェクトのみを対象とする
  OnlyVisible : Boolean = True;

//=============================================================================
//  ハンドル値がhWindowのウィンドウのオブジェクトを再帰的に検索して列挙
//  TreeViewのNodeに追加していく
//
//  hWindow     : ウィンドウのハンドル
//  Tree        : TreeView
//  dwID        : オブジェクトのカテゴリー
//=============================================================================
procedure EnumAccObjectTree(hWindow: HWND; Tree: TTreeView; dwID: Cardinal);
var
  oAccessible : IAccessible;
  RootNode    : TTreeNode;
begin
  Tree.Items.Clear;

  //ウィンドウハンドルからIAccessibleオブジェクトを取得
  if AccessibleObjectFromWindow(hWindow,
                                dwID,
                                IID_IAccessible,
                                Pointer(oAccessible)) <> S_OK then exit;

  //ルートノード
  RootNode := AddChildNode(oAccessible, CHILDID_SELF, Tree, nil);

  Tree.Items.BeginUpdate;
  //列挙実行
  EnumAccTreeItems(oAccessible, Tree, RootNode);
  Tree.Items.EndUpdate;
  Tree.TopItem.Expand(False);
end;

//=============================================================================
//  Acc階層下の子オブジェクトを列挙
//  TreeViewにツリー表示する
//=============================================================================
procedure EnumAccTreeItems(Acc: IAccessible; ATree: TTreeView; ANode: TTreeNode);
var
  Children   : array of TVariantArg;
  ChildCount : Integer;
  Obtained   : Integer;
  AccChDisp  : IDispatch;
  AccChild   : IAccessible;
  ChildID    : Integer;
  i          : Integer;
  j          : Integer;
  AddNode    : TTreeNode;
  HasChild   : Integer;
begin
  if Acc = nil then exit;

  //子オブジェクトの数を調べる
  if (Acc.get_accChildCount(ChildCount) = S_OK) then begin
    Application.ProcessMessages;
    SetLength(Children, ChildCount);

    //バリアント配列の初期化
    for i := 0 to ChildCount - 1 do begin
      VariantInit(OleVariant(Children[i]));
    end;

    //アクセス可能な子オブジェクトの数を調査
    if AccessibleChildren(Acc, 0, ChildCount, @Children[0], @Obtained) = S_OK
        then begin
      for j := 0 to Obtained - 1 do begin
        HasChild := -1;
        ChildID  := CHILDID_SELF;

        //子オブジェクトがある
        if Children[j].vt = VT_DISPATCH then begin
          AccChDisp := IDispatch(Children[j].pdispVal);
          if Assigned(AccChDisp) then begin
            AccChDisp.QueryInterface(IID_IAccessible, AccChild);
            ChildID  := CHILDID_SELF;
            HasChild := 1;
          end;
        end else begin
          if Children[j].vt = VT_I4 then begin
            //子オブジェクトはない
            if Acc.get_accChild(OleVariant(Children[j]), AccChDisp) = S_FALSE
                then begin
              AccChild := Acc;
              ChildID  := Children[j].lVal;
              HasChild := 0;
            end else begin
               //子オブジェクトがある
              if Assigned(AccChDisp) then begin
                AccChDisp.QueryInterface(IID_IAccessible, AccChild);
                ChildID  := CHILDID_SELF;
                HasChild := 1;
              end;
            end;
          end;
        end;

        //処理を1か所にまとめるためにHasChildをフラグとして使用
        if HasChild >= 0 then begin
          AddNode := AddChildNode(AccChild, ChildID, ATree, ANode);
          if (AddNode <> nil) and (HasChild = 1) then begin
            EnumAccTreeItems(AccChild, ATree, AddNode);
          end;
        end;
      end;
    end;
    //バリアント配列の後始末
    for i := 0 to Obtained - 1 do begin
      VariantClear(OleVariant(Children[i]));
    end;
  end;
end;

//=============================================================================
//  以下の処理を行う関数
//
//  TreeViewのノードに表示するテキスト作成
//  TreeViewにノードを追加
//  ノードのDataプロパティにオブジェクトの情報を，レコード型で代入
//
//  戻り値は，追加したノードのインスタンス
//  非可視のオブジェクトはノードに追加しないで，戻り値にnilを返す
//=============================================================================
function AddChildNode(AccChild: IAccessible; ChildID: Integer; ATree: TTreeView;
  ANode: TTreeNode): TTreeNode;
var
  AName    : WideString;
  varRole  : OleVariant;
  Len      : Cardinal;
  TmpStr   : WideString;
  varID    : OleVariant;
  StrText  : WideString;
  pAccInfo : PplAccInfoRec;
begin
  Result  := nil;
  StrText := '';

  //可視状態のオブジェクトのみの場合，非可視のオブジェクトは追加しない
  if OnlyVisible then begin
    if not IsAccObjectVisible(AccChild, ChildID) then exit;
  end;

  //Role(オブジェクトの機能，役割)プロパティを文字列として取得
  TVariantArg(varID).vt   := VT_I4;
  TVariantArg(varID).lVal := ChildID;
  if AccChild.get_accRole(varID, varRole) = S_OK then begin
    if TVariantArg(varRole).vt = VT_I4 then begin
      Len := GetRoleTextW(TVariantArg(varRole).lVal, nil, 0);
      SetLength(TmpStr, Len);
      GetRoleTextW(TVariantArg(varRole).lVal, PWideChar(TmpStr), Len + 1);
      StrText := '[' + TmpStr + ']';
    end else begin
      StrText := '[' + String(varRole) + ']';
    end;
  end else begin
    StrText := '[]';
  end;

  //Nameプロパティを取得して追加
  //Roleプロパティの文字列の後ろに追加
  if AccChild.get_accName(varID, AName) <> S_OK then AName := '';
  StrText := StrText + ' "' + AName + '"';

  //オブジェクトが可視か非可視かの文字列を追加
  //もしかしたら，非可視のオブジェクトもツリー表示するテストをしたい人がいるかも
  //しれないので追加
  if not OnlyVisible then begin
    if IsAccObjectVisible(AccChild, ChildID) then begin
      StrText := StrText + ' ' + 'Visible';
    end else begin
      StrText := StrText + ' ' + 'InVisible';
    end;
  end;

  Result := ATree.Items.AddChild(ANode, StrText);

  //NodeのDataプロパティにオブジェクトの情報を代入
  if Result <> nil then begin
    New(pAccInfo);
    pAccInfo.ChildID := ChildID;
    pAccInfo.pAcc    := AccChild;
    Result.Data      := pAccInfo;
  end;
end;

//=============================================================================
//  オブジェクトのプロパティの値を取得して，ListViewに追加していく
//  get_accFocus関数とget_accSelection関数による値は省略
//
//  ListViewのViewStyleがvsReportで，カラムが2つあると仮定している時のコード
//=============================================================================
procedure AccObjectInfo(LV : TListView; Node: TTreeNode);

  //---------------------------------------------------------------------------
  //  ウィンドウのクラス名を取得する関数
  //---------------------------------------------------------------------------
  function GetClassNameStr(hWindow: HWND): String;
  var
    Buffer : array[0..MAX_PATH-1] of Char;
    Len    : Integer;
  begin
    System.FillChar(Buffer, SizeOf(Buffer), #0);
    Len := Windows.GetClassName(hWindow, Buffer, Length(Buffer));
    if Len > 0 then Result := Buffer else Result := '';
  end;

  //---------------------------------------------------------------------------
  //  ListViewにItemを追加するメソッド
  //---------------------------------------------------------------------------
  procedure ListViewItemAdd(LV: TListView; ACaption, SubItem: String);
  var
    LVItem : TListItem;
  begin
    LVItem               := LV.Items.Add;
    LVItem.Caption       := ACaption;
    LVItem.SubItems.Text := SubItem;
  end;
  //---------------------------------------------------------------------------

var
  pAccInfo : PplAccInfoRec;
  Acc      : IAccessible;
  ChildID  : Integer;
  hWindow  : HWND;
  StrText  : WideString;
  ATop     : Integer;
  ALeft    : Integer;
  AWidth   : Integer;
  AHeight  : Integer;
  varChild : OleVariant;
  varState : OleVariant;
  varRole  : OleVariant;
  TmpInt   : Integer;
  Len      : Cardinal;
  i        : Integer;
  StateID  : Integer;
  TmpStr   : String;
begin
  if Node.Data = nil then exit;

  LV.Items.Clear;
  //NodeのDataプロパティからオブジェクトのデータを取出す
  pAccInfo := Node.Data;
  Acc      := pAccInfo.pAcc;
  ChildID  := pAccInfo.ChildID;

  LV.Items.BeginUpdate;

  StrText := '';
  hWindow := 0;
  if WindowFromAccessibleObject(Acc, hWindow) = S_OK then begin
    ListViewItemAdd (LV, 'Class Name', GetClassNameStr(hWindow));
  end;

  TVariantArg(varChild).vt   := VT_I4;
  TVariantArg(varChild).lVal := ChildID;

  if Acc.Get_accName(varChild, StrText) = S_OK then begin
    ListViewItemAdd (LV, 'Name', StrText);
  end else begin
    ListViewItemAdd (LV, 'Name', '-');
  end;

  StrText := '-';
  if Acc.get_accRole(varChild, varRole) = S_OK then begin
    if TVariantArg(varRole).vt = VT_I4 then begin
      Len := GetRoleTextW(TVariantArg(varRole).lVal, nil, 0);
      SetLength(StrText, Len);
      GetRoleTextW(TVariantArg(varRole).lVal, PWideChar(StrText), Len + 1);
    end;
  end;
  ListViewItemAdd (LV, 'Role', StrText);

  if Acc.accLocation(ALeft, ATop, AWidth, AHeight, varChild) = S_OK then begin
    if AWidth * AHeight <> 0 then begin
      StrText := '( ' + IntToStr(ALeft) + ', ' +
                        IntToStr(ATop)  + ', ' +
                        IntToStr(ALeft  + AWidth)  + ', ' +
                        IntToStr(ATop   + AHeight) + ' )';
      ListViewItemAdd (LV, 'Location', StrText);
    end else begin
      ListViewItemAdd (LV, 'Location', '-');
    end;
  end else begin
    ListViewItemAdd (LV, 'Location', '-');
  end;

  //Get_accChildCount関数で取得すると非可視のオブジェクトも含まれるので
  //ここではTreeViewの子ノードの数を表示
  ListViewItemAdd (LV, 'ChildCount', IntToStr(Node.Count));

  if Acc.Get_accDefaultAction(varChild, StrText) = S_OK then begin
    ListViewItemAdd (LV, 'DefaultAction', StrText);
  end else begin
    ListViewItemAdd (LV, 'DefaultAction', '-');
  end;

  if Acc.Get_accDescription(varChild, StrText) = S_OK then begin
    ListViewItemAdd (LV, 'Description', StrText);
  end else begin
    ListViewItemAdd (LV, 'Description', '-');
  end;

  if Acc.Get_accHelp(varChild, StrText) = S_OK then begin
    ListViewItemAdd (LV, 'Help', StrText);
  end else begin
    ListViewItemAdd (LV, 'Help', '-');
  end;

  if Acc.Get_accHelpTopic(StrText, varChild, TmpInt) = S_OK then begin
    ListViewItemAdd (LV, 'HelpTopic', StrText + ' ( ' + IntToStr(TmpInt) + ' )');
  end else begin
    ListViewItemAdd (LV, 'HelpTopic', '-');
  end;

  if Acc.Get_accKeyboardShortcut(varChild, StrText) = S_OK then begin
    ListViewItemAdd (LV, 'KeyboardShortcut', StrText);
  end else begin
    ListViewItemAdd (LV, 'KeyboardShortcut', '-');
  end;

  //Stateプロパティの値を取得して，GetStateTextW関数で説明文字列に変換
  //Stateは複数の場合がある
  //Stateプロパティの値が2の倍数で増加していくことを利用してループ処理
  StrText := '';
  StateID := 1;
  if Acc.Get_accState(varChild, varState) = S_OK then begin
    if TVariantArg(varState).vt = VT_I4 then begin
      TmpInt := TVariantArg(varState).lVal;
      for i := 1 to 29 do begin
        if (TmpInt and StateID) <> 0 then begin
          Len := GetStateTextW(StateID, nil, 0);
          SetLength(TmpStr, Len);
          GetStateTextW(StateID, PWideChar(TmpStr), Len);
          StrText := StrText + Trim(TmpStr) + '。' ;
        end;
        StateID := StateID * 2;
      end;
    end;
  end;
  ListViewItemAdd (LV, 'State', StrText);

  //最初の1行のみの表示となる(出力先がTListViewなので複数行表示は不可)
  if Acc.Get_accValue(varChild, StrText) = S_OK then begin
    ListViewItemAdd (LV, 'Value', StrText);
  end else begin
    ListViewItemAdd (LV, 'Value', '-');
  end;

  ListViewItemAdd (LV, 'ChildID', IntToStr(ChildID));

  LV.Items.EndUpdate;
end;

//=============================================================================
//  Valueプロパティ取得専用の関数
//=============================================================================
function GetAccObjectValue(Acc: IAccessible; ChildID: Integer): String;
var
  varChild : OleVariant;
  StrText  : WideString;
begin
  Result := '';

  TVariantArg(varChild).vt   := VT_I4;
  TVariantArg(varChild).lVal := ChildID;

  if Acc.Get_accValue(varChild, StrText) = S_OK then begin
    Result := StrText;
  end;
end;

//=============================================================================
//  オブジェクトの位置とサイズを，TRectレコード型に取得する関数
//=============================================================================
function GetAccObjectRect(Acc: IAccessible; ChildID: Integer): TRect;
var
  ATop     : Integer;
  ALeft    : Integer;
  AWidth   : Integer;
  AHeight  : Integer;
  varChild : OleVariant;
begin
  TVariantArg(varChild).vt   := VT_I4;
  TVariantArg(varChild).lVal := ChildID;

  if Acc.accLocation(ALeft, ATop, AWidth, AHeight, varChild) = S_OK then begin
    Result.Top    := ATop;
    Result.Left   := ALeft;
    Result.Right  := ALeft + AWidth;
    Result.Bottom := ATop  + AHeight;
  end;
end;

//=============================================================================
//  オブジェクトの可視状態を取得する関数
//  可視状態ならTrue，非可視であればFlaseを返す
//  MSDNによれば，この値は必ずしも正確ではないようだ
//  親オブジェクトの状態も考慮すべきとある
//=============================================================================
function IsAccObjectVisible(Acc: IAccessible; ChildID: Integer): Boolean;
var
  varChild : OleVariant;
  varState : OleVariant;
  VState   : Cardinal;
begin
  Result := True;

  TVariantArg(varChild).vt   := VT_I4;
  TVariantArg(varChild).lVal := ChildID;

  if Acc.Get_accState(varChild, varState) = S_OK then begin
    if TVariantArg(varState).vt = VT_I4 then begin
      VState :=  TVariantArg(varState).lVal;
      Result := (VState and STATE_SYSTEM_INVISIBLE) = 0;
    end;
  end;
end;

end.

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    Memo1: TMemo;
    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    { Private 宣言 }
    hEventHook : THandle;
    hTargetWnd : HWND;
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses OleAcc;

{$R *.dfm}

// Delphi XEにはないので定義
function AccessibleObjectFromEvent(hWnd : HWND; dwObjewctID : DWORD;
  dwChildID : DWORD; out pacc : IAccessible; out pvarChild   : OleVariant):
  HResult;  stdcall; external 'OLEACC.DLL';

//-----------------------------------------------------------------------------
//  ウィンドウのクラス名を取得する関数
//-----------------------------------------------------------------------------
function GetClassNameStr(hWindow: HWND): String;
var
  Buffer : array[0..MAX_PATH-1] of Char;
  Len    : Integer;
begin
  System.FillChar(Buffer, SizeOf(Buffer), #0);
  Len := Windows.GetClassName(hWindow, Buffer, Length(Buffer));
  if Len > 0 then Result := Buffer else Result := '';
end;

//-----------------------------------------------------------------------------
//  フック関数SetWinEventHookのコールバック関数
//
//  AccessibleObjectFromEventは使う必要がなければ使わない方がよい
//  オブジェクトの数が多いアプリだと，初回の処理に時間がかかることがある
//  ここではサンプルとして，使用する場面を考慮して書いてある
//-----------------------------------------------------------------------------
procedure WinEventProc(hWinEventHook: THandle; event: DWORD; hwnd: HWND;
  idObject, idChild: Longint; idEventThread, dwmsEventTime: DWORD); stdcall;
var
  acc      : IAccessible;
  varChild : OleVariant;
begin
  //イベントの引数からAcc(IAccessible)とvarChild(OleVariant)を取得
  //このサンプルでは，実際にはこれらの値を使用していない
  if AccessibleObjectFromEvent(hwnd, idObject, idChild, acc, varChild) = S_OK
    then begin

    if Form1.hTargetWnd = 0 then begin
      if GetClassNameStr(hwnd) = 'XLMAIN' then begin
        if event = EVENT_OBJECT_CREATE then begin
          Form1.hTargetWnd := hwnd;
          Form1.Memo1.Lines.Add('エクセルが起動しました');
        end;
      end;
    end else begin
      if Form1.hTargetWnd = hwnd then begin
        if event = EVENT_SYSTEM_MINIMIZESTART then begin
          Form1.Memo1.Lines.Add('エクセル最小化されました');
        end else
        if event = EVENT_SYSTEM_MINIMIZEEND then begin
          Form1.Memo1.Lines.Add('エクセルが元のサイズに戻りました');
        end;
      end else
      if Form1.hTargetWnd <> 0 then begin
        if GetClassNameStr(Form1.hTargetWnd) = '' then begin
          Form1.hTargetWnd := 0;
          Form1.Memo1.Lines.Add('エクセルが終了しました');
        end;
      end;
    end;
  end;
end;

//=============================================================================
//  [Start HOOK] フック開始
//  hTargetWnd  : 対象アプリのハンドル(このサンプルではエクセル)
//  hEventHook  : フックのハンドル
//
//  このサンプルでは，フック開始後，最初に起動したエクセルだけを対象にしている
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
begin
  if hEventHook = 0 then begin
    hEventHook := SetWinEventHook(
                             EVENT_MIN,
                             EVENT_MAX,
                             0,
                             WinEventProc,
                             0,
                             0,
                             WINEVENT_OUTOFCONTEXT);
    if hEventHook = 0 then begin
      Memo1.Lines.Add('フック関数の登録失敗');
    end else begin
      Memo1.Lines.Add('フック開始');
      Memo1.Lines.Clear;
    end;
  end;
end;

//=============================================================================
//  [Stop HOOK] フックの終了
//=============================================================================
procedure TForm1.Button2Click(Sender: TObject);
begin
  if hEventHook = 0 then begin
    Memo1.Lines.Add('フックは終了しています');
  end else begin
    UnhookWinEvent(hEventHook);
    hEventHook := 0;
    hTargetWnd := 0;
    Memo1.Lines.Add('フック終了');
  end;
end;

//=============================================================================
//  フォームの作成時　変数の初期化
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
begin
  hEventHook := 0;
  hTargetWnd := 0;
end;

//=============================================================================
//  フォームを閉じる時は，フックを終了させる
//=============================================================================
procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
  if hEventHook <> 0 then UnhookWinEvent(hEventHook);
end;

end.

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ComCtrls, OleAcc, ActiveX, plWindowRectFormUnit;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    ListView1: TListView;
    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
    procedure FormCreate(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  protected
    procedure WMHotKey(var Message: TWMHotKey); message WM_HOTKEY;
  private
    { Private 宣言 }
    hEventHook     : THandle;
    RectForm       : TplWindowRectForm;
    hRectFormWnd   : HWND;
    OldRectWnd     : TRect;
    FlagEvent      : Boolean;
    RegistHotKeyID : Integer;
    procedure AccObjectInfoToListView(Acc: IAccessible; varChild: OleVariant;
      LV: TListView);
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

// Delphi XEにはないので定義
function AccessibleObjectFromEvent(hWnd : HWND; dwObjewctID : DWORD;
  dwChildID : DWORD; out pacc : IAccessible; out pvarChild   : OleVariant):
  HResult; stdcall; external 'OLEACC.DLL';
function AccessibleObjectFromPoint(ptScreen: TPOINT; out ppAcc: IAccessible;
  out pvarChild: OleVariant): HRESULT ; stdcall; external 'OLEACC.DLL';
function WindowFromAccessibleObject(paccContainer: IAccessible; var phwnd: HWND):
  HRESULT;stdcall; external 'OLEACC.DLL';
function GetRoleTextW(dwRole: DWORD; lpszRole: PWideChar;
  cchRoleMax: UINT): UINT; stdcall; external 'OLEACC.DLL';


//-----------------------------------------------------------------------------
//  フック関数SetWinEventHookのコールバック関数
//
//  マウスポイント下のオブジェクトを検出して，そのオブジェクトを囲む矩形を描画
//-----------------------------------------------------------------------------
procedure WinEventProc(hWinEventHook: THandle; event: DWORD; hwnd: HWND;
  idObject, idChild: Longint; idEventThread, dwmsEventTime: DWORD); stdcall;

  //---------------------------------------------------------------------------
  //  関数内関数
  //  オブジェクトAccの位置とサイズを取得
  //---------------------------------------------------------------------------
  function GetAccObjectRect(Acc: IAccessible; varChild: OleVariant): TRect;
  var
    ATop    : Integer;
    ALeft   : Integer;
    AWidth  : Integer;
    AHeight : Integer;
  begin
    if Acc.accLocation(ALeft, ATop, AWidth, AHeight, varChild) = S_OK then begin
      Result := Rect(ALeft, ATop, ALeft + AWidth, ATop + AHeight);
    end else begin
      SetRectEmpty(Result);
    end;
  end;
  //---------------------------------------------------------------------------

var
  MousePos   : TPoint;
  pAcc       : IAccessible;
  varChild   : OleVariant;
  hTargetWnd : Windows.HWND;
  RectAcc    : TRect;
  LineWidth  : Integer;
  LineColor  : TColor;
begin
  //イベント内の処理中は，イベント処理をしない
  if Form1.FlagEvent then exit;
  Form1.FlagEvent  := True;

  //マウスカーソル位置を取得
  GetCursorPos(MousePos);

  //マウスカーソル位置のIAccessibleオブジェクトを取得
  //AccessibleObjectFromPoint関数の戻り値のvarChildのvtは，常にVT_I4となっている
  if AccessibleObjectFromPoint(MousePos, pAcc, varChild) = S_OK then begin

    //オブジェクトのサイズと位置を検出して，前のサイズと位置が異なっていれば処理
    RectAcc := GetAccObjectRect(pAcc, varChild);
    if not EqualRect(RectAcc, Form1.OldRectWnd) then begin

      //このサンプルでは，オブジェクトを囲む矩形描画に透明なフォームを使用している
      //このフォームを対象外とするため，マウスカーソル下のハンドルを比較
      //オブジェクトを囲む矩形描画用のフォームだったら処理しない
      if WindowFromAccessibleObject(pAcc, hTargetWnd) = S_OK then begin
        if hTargetWnd <> Form1.hRectFormWnd then begin
          Form1.OldRectWnd := RectAcc;
          Form1.RectForm.Canvas.FillRect(Form1.RectForm.ClientRect);

          //枠線のサイズと色を指定して描画
          LineWidth := 4;
          LineColor := clRed;
          with Form1.RectForm.Canvas do begin
            Pen.Color := LineColor;
            Pen.Width := LineWidth;

            MoveTo (RectAcc.Left,  RectAcc.Top);
            LineTo (RectAcc.Right, RectAcc.Top);
            LineTo (RectAcc.Right, RectAcc.Bottom);
            LineTo (RectAcc.Left,  RectAcc.Bottom);
            LineTo (RectAcc.Left,  RectAcc.Top);
          end;
          //ListViewにオブジェクトの情報を表示
          Form1.AccObjectInfoToListView(pAcc, varChild, Form1.ListView1);
          Form1.RectForm.BringToFront;
        end;
      end;
    end;
  end;

  Form1.FlagEvent := False;
  varChild := Unassigned;
end;

//=============================================================================
//  このフォームのOnCreateイベント
//  フォームの作成時　変数の初期化
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
begin
  hEventHook := 0;

  Button1.Enabled := True;
  Button2.Enabled := False;
end;

//=============================================================================
//  このフォームのOnCloseQueryイベント
//  フォームを閉じる時は，フックを終了させる
//=============================================================================
procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
  Button2Click(nil);
end;

//=============================================================================
//  WM_HOTKEYメッセージ処理
//  登録したホットキーを検出したら，フック終了
//=============================================================================
procedure TForm1.WMHotKey(var Message: TWMHotKey);
begin
  if Message.HotKey = RegistHotKeyID then begin
    Button2Click(nil);
  end;
end;

//=============================================================================
//  [Start HOOK]ボタン
//  フック開始
//  hEventHook   : フックのハンドル
//  hRectFormWnd : オブジェクトを囲む枠線を描画するためのフォームのハンドル
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
begin
  SetRectEmpty(OldRectWnd);
  FlagEvent := False;

  ListView1.Items.Clear;
  if hEventHook = 0 then begin
    hEventHook := SetWinEventHook(
                             EVENT_MIN,
                             EVENT_MAX,
                             0,
                             WinEventProc,
                             0,
                             0,
                             WINEVENT_OUTOFCONTEXT);
    if hEventHook = 0 then begin
      MessageDlg('フック関数の登録失敗', mtInformation, [mbOK], 0);
    end else begin
      //オブジェクトの周囲を囲む枠線用のフォームを作成して表示
      //このフォームは透明なので，実際には見えない
      if not Assigned(RectForm) then begin
        RectForm := TplWindowRectForm.Create(Self);
        RectForm.Show;
        Sleep(100);
        //そのフォームのハンドルを取得しておく
        hRectFormWnd := FindWindow('TplWindowRectForm', nil);
      end else begin
        //表示中であれば，オブジェクトを囲む枠線を消去
        RectForm.Canvas.FillRect(RectForm.ClientRect);
      end;

      Button1.Enabled := False;
      Button2.Enabled := True;

      //アトムテーブルに文字列(ホットキーを識別する文字列)を登録
      //以後のホットキーの操作はこのResistHokkeyで行うことになる
      RegistHotKeyID := GlobalAddAtom('plObjectInfoUnderMouse');

      //ホットキーにとして[F11]を登録
      //本サンプルが終了するとこの設定は無効となる
      RegisterHotkey(Handle, RegistHotKeyID, 0, VK_F11);
    end;
  end;
end;

//=============================================================================
//  [Stop HOOK]ボタン
//  フックの終了
//=============================================================================
procedure TForm1.Button2Click(Sender: TObject);
begin
  UnhookWinEvent(hEventHook);
  hEventHook := 0;
  FlagEvent  := False;

  Button1.Enabled := True;
  Button2.Enabled := False;

  if RegistHotKeyID <> 0 then begin
    //アトムテーブルから関連した文字列を削除
    GlobalDeleteAtom(RegistHotKeyID);
    //ホットキーの登録解除
    UnregisterHotKey(Handle, RegistHotKeyID);
  end;

  //オブジェクトの周囲を囲む枠線用のフォームを解放
  if Assigned(RectForm) then begin
    RectForm.Close;
    FreeAndNil(RectForm);
  end;
end;

//=============================================================================
//  ListViewにオブジェクトAccの情報を取得して表示
//
//  ListView1のViewStyleはvsReportで，カラムは2つ
//  ListView1.Columns[1].AutoSize := Trueにしている
//=============================================================================
procedure TForm1.AccObjectInfoToListView(Acc: IAccessible; varChild: OleVariant;
  LV: TListView);

  //---------------------------------------------------------------------------
  //  関数内関数
  //  ウィンドウのクラス名を取得する関数
  //---------------------------------------------------------------------------
  function GetClassNameStr(hWindow: HWND): String;
  var
    Buffer : array[0..MAX_PATH-1] of Char;
    Len    : Integer;
  begin
    System.FillChar(Buffer, SizeOf(Buffer), #0);
    Len := Windows.GetClassName(hWindow, Buffer, Length(Buffer));
    if Len > 0 then Result := Buffer else Result := '';
  end;

  //---------------------------------------------------------------------------
  //  関数内関数
  //  ListViewにItemを追加するメソッド
  //---------------------------------------------------------------------------
  procedure ListViewItemAdd(LV: TListView; ACaption, SubItem: String);
  var
    LVItem : TListItem;
  begin
    LVItem               := LV.Items.Add;
    LVItem.Caption       := ACaption;
    LVItem.SubItems.Text := SubItem;
  end;
  //---------------------------------------------------------------------------

var
  hWindow : HWND;
  StrText : WideString;
  ATop    : Integer;
  ALeft   : Integer;
  AWidth  : Integer;
  AHeight : Integer;
  varRole : OleVariant;
  Len     : Cardinal;
begin
  LV.Items.Clear;

  LV.Items.BeginUpdate;

  //このオブジェクトを有するウィンドウのハンドル
  StrText := '';
  hWindow := 0;
  if WindowFromAccessibleObject(Acc, hWindow) = S_OK then begin
    ListViewItemAdd (LV, 'Class Name', GetClassNameStr(hWindow));
  end;

  //Roleプロパティ
  StrText := '-';
  if Acc.get_accRole(varChild, varRole) = S_OK then begin
    if TVariantArg(varRole).vt = VT_I4 then begin
      Len := GetRoleTextW(TVariantArg(varRole).lVal, nil, 0);
      SetLength(StrText, Len);
      GetRoleTextW(TVariantArg(varRole).lVal, PWideChar(StrText), Len + 1);
    end;
  end;
  ListViewItemAdd (LV, 'Role', StrText);

  //Nameプロパティ
  if Acc.Get_accName(varChild, StrText) = S_OK then begin
    ListViewItemAdd (LV, 'Name', StrText);
  end else begin

    ListViewItemAdd (LV, 'Name', '-');
  end;

  //Valueプロパティ
  if Acc.Get_accValue(varChild, StrText) = S_OK then begin
    ListViewItemAdd (LV, 'Value', StrText);
  end else begin
    ListViewItemAdd (LV, 'Value', '-');
  end;

  //Descriptionプロパティ
  if Acc.Get_accDescription(varChild, StrText) = S_OK then begin
    ListViewItemAdd (LV, 'Description', StrText);
  end else begin
    ListViewItemAdd (LV, 'Description', '-');
  end;

  //オブジェクトの幅と高さ
  AWidth  := 0;
  AHeight := 0;
  if Acc.accLocation(ALeft, ATop, AWidth, AHeight, varChild) = S_OK then begin
    ListViewItemAdd (LV, 'X',  IntToStr(ALeft));
    ListViewItemAdd (LV, 'Y',  IntToStr(ATop));
    ListViewItemAdd (LV, 'Width',  IntToStr(AWidth));
    ListViewItemAdd (LV, 'Height', IntToStr(AHeight));
  end;

  if Acc.Get_accDefaultAction(varChild, StrText) = S_OK then begin
    ListViewItemAdd (LV, 'DefaultAction', StrText);
  end else begin
    ListViewItemAdd (LV, 'DefaultAction', '-');
  end;

  //キーボードショートカット
  if Acc.Get_accKeyboardShortcut(varChild, StrText) = S_OK then begin
    ListViewItemAdd (LV, 'KeyboardShortcut', StrText);
  end else begin
    ListViewItemAdd (LV, 'KeyboardShortcut', '-');
  end;

  varRole := Unassigned;
  LV.Items.EndUpdate;
  Sleep(1);
end;

end.

unit plWindowRectFormUnit;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs;

type
  TplWindowRectForm = class(TForm)
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    { Private 宣言 }
    OriginalProc: TWndMethod;
    procedure SubClassProc(var Message: TMessage);
  public
    { Public 宣言 }
  end;

var
  plWindowRectForm: TplWindowRectForm;

implementation

{$R *.dfm}

//=============================================================================
//  元のWindowsProcを退避して新しいWindowProcを定義
//  この設定は用途によってはOnShowで設定する必要があるかも知れない
//  OnShow設定の場合は，OnCloseでWindowProcを元に戻しておいた方がいいだろう
//
//  このフォームはオブジェクトインスペクタで以下の設定をしている
//  この設定は，タスクバーの上にもこのフォームを重ねて表示する
//    RectForm.BorderIcons           := [biSystemMenu];
//    RectForm.BorderStyle           := bsNone;
//    RectForm.Color                 := clWhite;
//    RectForm.FormStyle             := fsStayOnTop;
//    RectForm.Position              := poDesigned;
//    RectForm.TransparentColor      := True;
//    RectForm.TransparentColorValue := clWhite;
//    RectForm.WindowState           := wsMaximized;
//=============================================================================
procedure TplWindowRectForm.FormCreate(Sender: TObject);
begin
  SetWindowLong(Handle, GWL_STYLE, WS_POPUP);

  OriginalProc    := Self.WindowProc;
  Self.WindowProc := SubClassProc;
end;

//=============================================================================
//  WindowsProcを元に戻しておく
//  このサンプルではOnCreateでWindowProcを設定しているので実際には不要
//=============================================================================
procedure TplWindowRectForm.FormDestroy(Sender: TObject);
begin
  Self.WindowProc := OriginalProc;
end;

//=============================================================================
//  WindowProcのサブクラス関数
//  このフォームがZオーダのトップかを監視して設定
//=============================================================================
procedure TplWindowRectForm.SubClassProc(var Message: TMessage);

  //Targetが最前面かを判定する関数
  function IsTopMost(Target: HWND): boolean;
  begin
    Result := ((GetWindowLong(Target, GWL_EXSTYLE) and WS_EX_TOPMOST) <> 0);
  end;

begin
  //元のWindowProcを実行
  OriginalProc(Message);

  //このフォームが最前面でなければ最前面にする
  if IsTopMost(Self.Handle) = False then begin
    SetWindowPos(Self.Handle,
                 HWND_TOPMOST,
                 0,
                 0,
                 0,
                 0,
                 SWP_NOACTIVATE or SWP_NOMOVE or SWP_NOSIZE or SWP_NOOWNERZORDER);
  end;
end;

end.

SetWinEventHook (eventMin,
                 eventMax,
                 hmodWinEventProc,
                 pfnWinEventProc,
                 idProcess,
                 idThread,
                 dwFlags): THandle

UnhookWinEvent (hWinEventHook): BOOL 

    dwFlags := WINEVENT_INCONTEXT;
    dwFlags := WINEVENT_OUTOFCONTEXT;
    dwFlags := WINEVENT_INCONTEXT or WINEVENT_SKIPOWNPROCESS;
    dwFlags := WINEVENT_INCONTEXT or WINEVENT_SKIPOWNTHREAD;
    dwFlags := WINEVENT_OUTOFCONTEXT or WINEVENT_SKIPOWNPROCESS;
    dwFlags := WINEVENT_OUTOFCONTEXT or WINEVENT_SKIPOWNTHREAD; 

WinEventProc(hWinEventHook,
             event,
             hwnd,
             idObject,
             idChild,
             idEventThread,
             dwmsEventTime)