IAccessible: получить активный адрес с нарушением доступа

Question

У меня проблема с отображением моей формы1 и прослушиванием активного URL-адреса в браузере. В коде следующее, после теста с функцией ShowMessage, apper в Асесс нарушения в моем проекте, как на следующих изображениях:

IMAGE_! и IMAGE_2

Вот мой код:

unit Unit1; 

interface 

uses 
    Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, 
    Dialogs, StdCtrls, { MSAAIntf, } Oleacc, ActiveX; 

type 
    HWINEVENTHOOK = DWORD; 

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

var 
    Form1: TForm1; 
    Memo1: TMemo; 
    vHook: HWINEVENTHOOK = 0; 
    Eventos: Boolean = false; 
    UrlAtiva, UrlVelha: WideString; 

implementation 

{$R *.dfm} 

procedure WinEventProc(HWINEVENTHOOK: THandle; event: DWORD; hwnd: hwnd; 
    idObject, idChild: Longint; idEventThread, dwmsEventTime: DWORD); stdcall; 

var 
    vAccObj: IAccessible; 
    varChild: OleVariant; 
    vWSName, vWSValue: WideString; 
    ClassName: String; 
    Acesso: HResult; 

begin 
    vAccObj := nil; 
    Acesso := AccessibleObjectFromEvent(hwnd, idObject, idChild, vAccObj, 
    varChild); 
    SetLength(ClassName, 255); 
    SetLength(ClassName, GetClassName(hwnd, pchar(ClassName), 255)); 

    IF (Acesso = S_OK) and (vAccObj <> nil) THEN 
    BEGIN 
    vAccObj.Get_accName({ CHILDID_SELF } varChild, vWSName); 
    vAccObj.Get_accValue({ CHILDID_SELF } varChild, vWSValue); 
    END; 

    IF (pchar(ClassName) = 'Chrome_WidgetWin_1') AND (Eventos = true) AND 
    (vWSName = 'Address and search bar') AND (vWSValue <> '<null>') THEN 

    UrlAtiva := vWSValue; 

    IF (UrlAtiva <> UrlVelha) THEN 

    BEGIN 
    UrlVelha := UrlAtiva; 
    Memo1.Lines.Add(UrlAtiva); 
    end; 

    vAccObj._Release; 
end; 

procedure Unhook; 

begin 
    if (vHook = 0) then 
    Exit; 

    UnhookWinEvent(vHook); 
    CoUninitialize; 
end; 

procedure Hook; 

begin 
    if (vHook <> 0) then 
    Exit; 

    CoInitialize(nil); 
    vHook := SetWinEventHook(EVENT_OBJECT_FOCUS, EVENT_OBJECT_VALUECHANGE, 0, 
    WinEventProc, 0, 0, WINEVENT_SKIPOWNPROCESS); 
end; 

function Thread_Infinite(navegador: Pointer = nil): DWORD; stdcall; 

var 

    wH: array of THandle; 
    wR: DWORD; 
    Msg: TMSG; 
    leave: Boolean; 

begin 
    wH := navegador; 
    leave := false; 
    Hook; 

    repeat 
    wR := MsgWaitForMultipleObjects(1, wH, false, INFINITE, QS_ALLEVENTS); 

    case wR of 

     WAIT_ABANDONED: 
     ; 
     WAIT_FAILED: 
     ; 
     WAIT_OBJECT_0: 
     begin 
      leave := true; 
      break; 
     end; 

     WAIT_OBJECT_0 + 1: 
     while PeekMessage(Msg, 0, 0, 0, PM_REMOVE) do 
     begin 
      TranslateMessage(Msg); 
      DispatchMessage(Msg); 
     end; 
    end; 
    break; 

    Until not leave; 
    Unhook; 
    Result := 0; 
end; 

function inicia_tudo: integer; 

var 
    szFileName: array [0 .. 100] of char; 
    szModuleName: array [0 .. 19] of char; 
    iSize: integer; 
    threadId: DWORD; 
    Stop, Thread: THandle; 
begin 
    StrPCopy(szModuleName, 'Project1'); 
    iSize := GetModuleFileName(GetModuleHandle(szModuleName), szFileName, 
    SizeOf(szFileName)); 
    if iSize > 0 then 
    begin 
    ShowMessage(StrPas(szFileName)); 
    Eventos := true; 
    end; 

    Stop := CreateEvent(nil, true, false, nil); 
    Thread := CreateThread(nil, 0, (Pointer(Thread_Infinite)), (Pointer(Stop)), 
    0, threadId); 

    SetEvent(Stop); 

    WaitForSingleObject(Thread, 5000); 

    CloseHandle(Thread); 
    CloseHandle(Stop); 

    Result := 0; 
end; 

procedure TForm1.FormCreate(Sender: TObject); 
begin 
    inicia_tudo; 
end; 

end. 

Answer 1

Вместо этого попробуйте нечто подобное:

unit Unit1; 

interface 

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

    TForm1 = class(TForm) 
    Memo1: TMemo; 
    procedure FormCreate(Sender: TObject); 
    procedure FormDestroy(Sender: TObject); 
    private 
    { Private declarations } 
    procedure AddUrlToMemo; 
    public 
    { Public declarations } 
    end; 

var 
    Form1: TForm1; 

implementation 

uses 
    { MSAAIntf, } Oleacc, ActiveX; 

{$R *.dfm} 

type 
    HWINEVENTHOOK = THandle; 

var 
    UrlVelha: WideString; 
    Thread: THandle = 0; 
    ThreadId: DWORD = 0; 

procedure WinEventProc(hWinEventHook: HWINEVENTHOOK; event: DWORD; hwnd: HWND; 
    idObject, idChild: Longint; idEventThread, dwmsEventTime: DWORD); stdcall; 
var 
    vAccObj: IAccessible; 
    varChild: OleVariant; 
    vWSName, vWSValue: WideString; 
    ClassName: String; 
    Acesso: HResult; 
begin 
    SetLength(ClassName, 255); 
    SetLength(ClassName, GetClassName(hwnd, PChar(ClassName), 255)); 

    if (ClassName = 'Chrome_WidgetWin_1') then 
    begin 
    Acesso := AccessibleObjectFromEvent(hwnd, idObject, idChild, vAccObj, varChild); 
    If (Acesso = S_OK) and (vAccObj <> nil) then 
    begin 
     vAccObj.Get_accName({ CHILDID_SELF } varChild, vWSName); 
     if (vWSName = 'Address and search bar') then 
     begin 
     vAccObj.Get_accValue({ CHILDID_SELF } varChild, vWSValue); 
     if (vWSValue <> '') and (vWSValue <> '<null>') and (UrlVelha <> vWSValue) then 
     begin 
      UrlVelha := vWSValue; 
      TThread.Synchronize(nil, Form1.AddUrlToMemo); 
     end; 
     end; 
    end; 
    end; 
end; 

function Thread_Infinite(param: Pointer): DWORD; stdcall; 
var 
    Msg: TMSG; 
    vHook: HWINEVENTHOOK; 
begin 
    CoInitialize(nil); 

    vHook := SetWinEventHook(EVENT_OBJECT_FOCUS, EVENT_OBJECT_VALUECHANGE, 0, 
    @WinEventProc, 0, 0, WINEVENT_SKIPOWNPROCESS); 

    while GetMessage(Msg, 0, 0, 0) do 
    begin 
    TranslateMessage(Msg); 
    DispatchMessage(Msg); 
    end; 

    if (vHook <> 0) then 
    UnhookWinEvent(vHook); 

    CoUninitialize; 
    Result := 0; 
end; 

procedure TForm1.FormCreate(Sender: TObject); 
begin 
    Thread := CreateThread(nil, 0, @Thread_Infinite, nil, 0, ThreadId); 
end; 

procedure TForm1.FormDestroy(Sender: TObject); 
begin 
    if (ThreadId <> 0) then 
    PostThreadMessage(ThreadId, WM_QUIT, 0, 0); 
    if (Thread <> 0) then 
    begin 
    repeat 
     if (WaitForSingleObject(Thread, 5000) <> WAIT_TIMEOUT) then 
     Break; 
     CheckSynchronize; 
    until False; 
    CloseHandle(Thread); 
    end; 
end; 

procedure TForm1.AddUrlToMemo; 
begin 
    if (Memo1 <> nil) and (not (csDestroying in ComponentState)) then 
    Memo1.Lines.Add(UrlVelha); 
end; 

end.