Jak przejść do ścieżki wskazanej w <a href> w TWebBrowser?

0

Witam,

mam TWebBrowser (okno czatu), do którego ładowane są wiadomości za pomocą kodu:

// Memo1.Lines - treść wysyłanej wiadomości
RichEditToWB(WebBrowser1, Memo1.Lines);
procedure TfrmRozmowa.RichEditToWB(AWebBrowser: TWebBrowser; AHTMLCode: TStrings);
var
  Documentx: OleVariant;
begin
  if AWebBrowser.Document = nil then
    AWebBrowser.Navigate('about:blank');
  Documentx:=AWebBrowser.Document;
  Documentx.Write(AHTMLCode.Text);
  Documentx.Close;

  Application.ProcessMessages;
  WB_ScrollTo(WebBrowser1, wbPosBottom);
end;

Mam obsłużone zdarzenie OnBeforeNavigate2:

procedure TfrmRozmowa.WebBrowser1BeforeNavigate2(ASender: TObject;
  const pDisp: IDispatch; const URL, Flags, TargetFrameName, PostData,
  Headers: OleVariant; var Cancel: WordBool);
var
  s: string;
begin
  Flag := Flags;

  if (Flags = 64) or (Flags = 320) and (IsURL(URL)) then
    begin
      Cancel := True;

      s := StringReplace(URL, 'about:', '', [rfReplaceAll]);
      ShellExecute(0, nil,  PWideChar(s), nil, nil, SW_SHOW);
    end;
end;

Lecz w przypadku, gdy w webbrowserze klikam na link w postaci:

<a href="file:///c:\plik.txt">Tutaj plik</a>

to nic się nie dzieje, a co gorsza - zdarzenie before navigate nie reaguje (break point)

W jaki sposób mogę obsługiwać linki klikane za pomocą kursora?

Wiadomości ładowane są z bazy danych.

dodanie znacznika <code class="html"> - @furious programming

3

Da się to zrobić, zobacz przykład:

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, OleCtrls, SHDocVw,  MSHTML, StdCtrls, ActiveX;

type
  TOnElementClickEvent = procedure(Sender: TObject; Element: IHTMLElement) of object;

  TWebBrowser = class(SHDocVw.TWebbrowser, IDispatch)
  private
    FOnElementClickEvent: TOnElementClickEvent;
    function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
        Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HRESULT; stdcall;
    procedure DocumentComplete(Sender: TObject; const pDisp: IDispatch; var URL: OleVariant);
  public
    procedure LoadHTMLFromStrings(AHTML: TStrings);
    property OnElementClickEvent: TOnElementClickEvent read FOnElementClickEvent write FOnElementClickEvent;
    constructor Create(AOwner: TComponent); override;
  end;

  TForm1 = class(TForm)
    WebBrowser1: TWebBrowser;
    Memo1: TMemo;
    Button1: TButton;
    procedure FormCreate(Sender: TObject);
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
    procedure WebBrowserElementClick(Sender: TObject; Element: IHTMLElement);
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}


function TWebBrowser.Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
     Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HRESULT;
var
  Doc: IHTMLDocument2;
  Element: IHTMLElement;
begin
  case DispID of
    0: begin
         Doc:= Document as IHTMLDocument2;
         if Assigned(Doc) then
         begin
           Element:= Doc.activeElement;
           if Assigned(Element) and Assigned(FOnElementClickEvent) then
             FOnElementClickEvent(Self, Element);
         end;
         Result:= S_OK;
       end;
    else
      Result:= inherited Invoke(DispID, IID, LocaleID, Flags, Params, VarResult, ExcepInfo, ArgErr);
  end;
end;

procedure TWebBrowser.LoadHTMLFromStrings(AHTML: TStrings);
var
  StringStream: TStringStream;
  PersistStreamInit: IPersistStreamInit;
begin
  if not Assigned(Document) then
  begin
    Navigate('about:blank');

    while ReadyState <> READYSTATE_COMPLETE do
    begin
      Forms.Application.ProcessMessages;
    end;
  end;
  if (Document.QueryInterface(IPersistStreamInit, PersistStreamInit) = S_OK) then
  begin
    if (PersistStreamInit.InitNew <> S_OK) then exit;
    StringStream:= TStringStream.Create(AHTML.Text);
    try
    PersistStreamInit.Load(TStreamAdapter.Create(StringStream));
    finally
    StringStream.Free;
    end;
  end;
end;

procedure TWebBrowser.DocumentComplete(Sender: TObject; const pDisp: IDispatch; var URL: OleVariant);
var
  Doc: IHTMLDocument2;
begin
  Doc:= Document as IHTMLDocument2;
  OleVariant(Doc).attachEvent('onclick', OleVariant(Self as IDispatch));
  inherited;
end;

constructor TWebBrowser.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  OnDocumentComplete:= DocumentComplete;
end;

procedure TForm1.WebBrowserElementClick(Sender: TObject; Element: IHTMLElement);
var
  Link: string;
begin
  if SameText(LowerCase(Element.tagName), 'a') then //to jest link
  begin
    if Element.getAttribute('href', 0) <> null then
    begin
      Link:= Element.getAttribute('href', 0);
      ShowMessage(Link);
      WebBrowser1.Navigate(Link);
    end;
  end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  WebBrowser1.OnElementClickEvent:= WebBrowserElementClick;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  WebBrowser1.LoadHTMLFromStrings(Memo1.Lines);
end;

end.

Rozwiązanie ma jedną wadę WebBrowser nie pozwala na nadpisanie zdarzeń (metody można) więc jeżeli byś chciał do jakiegoś celu wykorzystać zdarzenie OnDocumentComplete to aby to rozwiązanie działało koniecznie musisz w nim wstawić kod który podałem poniżej (jeżeli tego nie zrobisz to wykorzystane w powyższym kodzie zdarzenie OnDocumentComplete się nie wykona a wiec nie zostanie przypisana metoda OnClick do dokumentu dlatego bez tego kod nie będzie działał):

var
  Doc: IHTMLDocument2;
begin
  Doc:= Document as IHTMLDocument2;
  OleVariant(Doc).attachEvent('onclick', OleVariant(WebBrowser1 as IDispatch));
0

WIELKIE DZIĘKI @kAzek! działa pięknie, póki co.
Jeszcze raz dzięki!

Zarejestruj się i dołącz do największej społeczności programistów w Polsce.

Otrzymaj wsparcie, dziel się wiedzą i rozwijaj swoje umiejętności z najlepszymi.