我遇到了显示我的Form1并在浏览器上监听活动网址的问题。在下面的代码中,在使用showmessage函数进行测试之后,在我的项目中执行Acess违规,如下图所示:
这是我的代码:
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.
答案 0 :(得分: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.