I'm with a problem for show my Form1 and listen the active url in on browser. In code following, after the test with showmessage function, apper an Acess violation in my project as on following images:
Here is my code:
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.