Question

我遇到了显示我的Form1并在浏览器上监听活动网址的问题。在下面的代码中，在使用showmessage函数进行测试之后，在我的项目中执行Acess违规，如下图所示：

IMAGE_!和 IMAGE_2
enter image description here

这是我的代码：

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.

IAccessible：获取具有访问冲突的活动URL

1 个答案: