WebBrowser SinkEvents и DesignMode = 'on' - PullRequest
       24

WebBrowser SinkEvents и DesignMode = 'on'

2 голосов
/ 01 января 2012

Zarko Gajic демонстрирует, как получить URL-адрес гиперссылки, когда мышь перемещается над документом TWebBrowser, в следующей статье и демонстрации: http://delphi.about.com/od/vclusing/a/wbsinkevents.htm Эта демонстрация работает хорошо, пока WebBrowser не будет установлен на designmode = 'on'то событие OnMouseMove не выполняется.Можно ли улучшить демонстрацию, чтобы событие OnMouseMove выполнялось, когда DesignMode = 'on'?Если нет, то есть ли другой способ создания события Document.OnMouseMove?Я использую Delphi 2010.

[Редактировать] Больше кода было запрошено, поэтому вот реализация

procedure TForm1.DesignMode1Click( Sender: TObject );
var
  iDocument: MSHTML.IHTMLDocument2;
begin
  if Assigned( WebBrowser1 ) then
  begin
    iDocument := htmlDoc; //( WebBrowser1.Document as IHTMLDocument2 );
    if Assigned( iDocument ) then
    begin
      if DesignMode1.Checked then
        iDocument.DesignMode := 'On'
      else
        iDocument.DesignMode := 'Off';
      WebBrowser1.Refresh2;
    end;
  end;
end;

procedure TForm1.Document_OnMouseOver;
var
  element: IHTMLElement;
begin
  if htmlDoc = nil then
    Exit;

  element := htmlDoc.parentWindow.event.srcElement;

  elementInfo.Clear;

  if LowerCase( element.tagName ) = 'a' then
  begin
    elementInfo.Lines.Add( 'LINK info...' );
    elementInfo.Lines.Add( Format( 'HREF : %s', [ element.getAttribute( 'href', 0 ) ] ) );
  end
  else if LowerCase( element.tagName ) = 'img' then
  begin
    elementInfo.Lines.Add( 'IMAGE info...' );
    elementInfo.Lines.Add( Format( 'SRC : %s', [ element.getAttribute( 'src', 0 ) ] ) );
  end
  else
  begin
    elementInfo.Lines.Add( Format( 'TAG : %s', [ element.tagName ] ) );
  end;
end; (* Document_OnMouseOver *)

procedure TForm1.FormCreate( Sender: TObject );
begin
  WebBrowser1.Navigate( 'http://delphi.about.com' );
  elementInfo.Clear;
  elementInfo.Lines.Add( 'Move your mouse over the document...' );
end; (* FormCreate *)

procedure TForm1.WebBrowser1BeforeNavigate2( ASender: TObject; const pDisp: IDispatch;
  var URL, Flags, TargetFrameName, PostData, Headers: OleVariant; var Cancel: WordBool );
begin
  htmlDoc := nil;
end; (* WebBrowser1BeforeNavigate2 *)

procedure TForm1.WebBrowser1DocumentComplete( ASender: TObject; const pDisp: IDispatch; var URL: OleVariant );

begin
  if Assigned( WebBrowser1.Document ) then
  begin
    htmlDoc := WebBrowser1.Document as IHTMLDocument2;
    htmlDoc.onmouseover := ( TEventObject.Create( Document_OnMouseOver ) as IDispatch );
  end;
end; (* WebBrowser1DocumentComplete *)

{ TEventObject }

constructor TEventObject.Create( const OnEvent: TObjectProcedure );
begin
  inherited Create;
  FOnEvent := OnEvent;
end;

function TEventObject.GetIDsOfNames( const IID: TGUID; Names: Pointer; NameCount, LocaleID: Integer;
  DispIDs: Pointer ): HResult;
begin
  Result := E_NOTIMPL;
end;

function TEventObject.GetTypeInfo( Index, LocaleID: Integer; out TypeInfo ): HResult;
begin
  Result := E_NOTIMPL;
end;

function TEventObject.GetTypeInfoCount( out Count: Integer ): HResult;
begin
  Result := E_NOTIMPL;
end;

function TEventObject.Invoke( DispID: Integer; const IID: TGUID; LocaleID: Integer; Flags: Word; var Params;
  VarResult, ExcepInfo, ArgErr: Pointer ): HResult;
begin
  if ( DispID = DISPID_VALUE ) then
  begin
    if Assigned( FOnEvent ) then
      FOnEvent;
    Result := S_OK;
  end
  else
    Result := E_NOTIMPL;
end;

end.

[Исправить] Я понялтот WebBrowser1DocumentComplete не был выполнен после установки webbrowser для designmode, поэтому я изменил DesignMode1Click, и это решило проблему.Я публикую это, чтобы другие тоже могли это увидеть:

procedure TForm1.DesignMode1Click( Sender: TObject );
begin
  // the following is unsafe because you may click on the
  // check box even if you don't have any page navigated
  -- htmlDoc := WebBrowser1.Document as IHTMLDocument2;

  // htmlDoc will be assigned from the OnDocumentComplete
  // fired by Navigate procedure
  if Assigned( htmlDoc ) then
  begin
    if DesignMode1.Checked then
      htmlDoc.DesignMode := 'On'
    else
      htmlDoc.DesignMode := 'Off';

    // switching to design mode takes some time and if there 
    // are some pages which doesn't fire OnDocumentComplete 
    // event when you are switching to design mode, like
    // http://delphi.about.com do, then I would wait for 
    // web browser to be ready
    while WebBrowser1.ReadyState < READYSTATE_COMPLETE do
      Application.ProcessMessages;

    // release the previous "document instance"
    htmlDoc := nil;
    // assign the new one and attach the event
    htmlDoc := WebBrowser1.Document as IHTMLDocument2;
    htmlDoc.OnMouseOver := ( TEventObject.Create( Document_OnMouseOver ) as IDispatch );
  end;
end;
...