DELPHI AREA

[Zvikai]

How can it be done ?
Thank's.

[Kambiz]

I have written the following code for one commercial product. Although it is not accurate, but works.

Code: Select all

uses
  MShtml, StrUtils;

var
  NewBrowser: TWebBrowser; // this is a temporary browser

function GetActiveElement(const IDoc: IDispatch): IHTMLElementDisp;
var
  FrameWB: IWebBrowser2;
  Doc: IDispatch;
  Element: IHTMLElementDisp;
begin
  Result := nil;
  if IDoc <> nil then
  begin
    Doc := IDoc;
    repeat
      try
        Element := (Doc as IHTMLDocument2).ActiveElement as IHTMLElementDisp;
        if AnsiMatchText(Element.tagName, ['FRAME', 'IFRAME']) then
        begin
          if (Element as IHTMLElement).QueryInterface(IWebBrowser2, FrameWB) = S_OK then
            Doc := FrameWB.Document
          else if (Element as IHTMLElement).QueryInterface(IHTMLDocument2, Doc) <> S_OK then
            break;
        end
        else
          Break;
      except
        Break;
      end;
    until Element = nil;
    Result := Element;
  end;
end;

procedure TForm1.WebBrowser1BeforeNavigate2(Sender: TObject;
  const pDisp: IDispatch; var URL, Flags, TargetFrameName, PostData,
  Headers: OleVariant; var Cancel: WordBool);
var
  Element: IHTMLElementDisp;
begin
  if Sender = NewBrowser then
  begin
    Cancel := True;
    Element := GetActiveElement(WebBrowser1.Document);
    if Element <> nil then
    begin
      if AnsiMatchText(Element.tagName, ['A', 'BUTTON']) then
        Cancel := False
      else if not VarIsNull(Element.onclick) then
        Cancel := False
      else if AnsiSameText(Element.tagName, 'INPUT') then
        Cancel := not AnsiMatchText((Element as IHTMLInputElement).Type_, ['SUBMIT', 'BUTTON', 'IMAGE']);
    end;
    if not Cancel then
    begin
      // TODO: put the new browser for example on a new tab
      // TODO: Save new browser in another variable
      NewBrowser := nil;
    end;
  end;
end;

procedure TForm1.WebBrowser1NewWindow2(Sender: TObject;
  var ppDisp: IDispatch; var Cancel: WordBool);
begin
  if Assigned(NewBrowser) then
    NewBrowser.Free;  // the last new one was cancelled
  NewBrowser := TWebBrowser.Create(self);
  NewBrowser.OnBeforeNavigate2 := WebBrowser1BeforeNavigate2;
  ppDisp := NewBrowser.DefaultInterface;
end;