0

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:

IMAGE_1
IMAGE_2

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.

Edited by Luiz Eduardo

2
Contributors
1
Reply
7
Views
2 Years
Discussion Span
Last Post by darkagn
This topic has been dead for over six months. Start a new discussion instead.
Have something to contribute to this discussion? Please be thoughtful, detailed and courteous, and be sure to adhere to our posting rules.