Программирование на Delphi

FAQ VCL
Компоненты\WebBrowser

:: Меню ::

:: На главную ::

:: FAQ ::

:: Заметки ::

:: Практика ::

:: Win API ::

:: Проекты ::

:: Скачать ::

:: Секреты ::

:: Ссылки ::

:: Сервис ::

:: Написать ::

:: MVP ::

:: RSS ::

Как выполнить JavaScript в TWebBrowser?


// Способ первый
uses
  OleCtrls, SHDocVw, MSHTML;

type
  TWebBrowser = class(SHDocVw.TWebBrowser)
    procedure RunJS(js: string);
    function getElementATTR(tag, id, attr: string): string;
    function GetJsParam(Param: string): string;
    function GetJsArrayStrList(Param: string): TStringList;
  end;

  TForm1 = class(TForm)
    WebBrowser1: TWebBrowser;
    Button1: TButton;
    {...}
  end;

implementation

procedure TForm1.Button1Click(Sender: TObject);
begin
  WebBrowser1.RunJS('alert(window.location);');
  WebBrowser1.RunJS('alert(document.title);');
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  WebBrowser1.Navigate('http://www.decoding.dax.ru/');
end;

{ TWebBrowser }

function TWebBrowser.getElementATTR(tag, id, attr: string): string;
var
  Doc: IHTMLDocument2;
  Body: IHTMLElement2;
  Tags: IHTMLElementCollection;
  Tagg: IHTMLElement;
  i: Integer;
begin
  Result := '';

  if not Supports(Self.Document, IHTMLDocument2, Doc) then
    raise Exception.Create('Invalid HTML document');

  if not Supports(Doc.body, IHTMLElement2, Body) then
    raise Exception.Create('Can''t find  element');

  Tags := Body.getElementsByTagName(UpperCase(tag));
  for i := 0 to Pred(Tags.length) do
  begin
    Tagg := Tags.item(i, EmptyParam) as IHTMLElement;
    if Tagg.id = id then
      Result := Tagg.getAttribute(attr, 0);
  end;
end;

function TWebBrowser.GetJsArrayStrList(Param: string): TStringList;
var
  i, k: Integer;
begin
  Result := TStringList.Create;
  if (GetJsParam('((' + param + '!=null)&&(typeof(' + param +
        ')==''object'')&&(typeof(' + param + '.length)==''number''))')='true') then
  begin
    k := StrToInt(GetJsParam(param + '.length'));
    for i := 0 to k-1 do
      Result.Add(GetJsParam(param + '[' + IntToStr(i) + ']'));
  end;
end;

function TWebBrowser.GetJsParam(Param: string): string;
begin
  Self.RunJS('var d=document.getElementById(''delphi_result'');' +
             'if (!d) {' +
             'd=document.createElement(''input'');' +
             'd.type=''hidden'';' +
             'd.id=''delphi_result'';' +
             'document.body.appendChild(d);}' +
             'd.value=' + param + ';');
  Result := Self.getElementATTR('input', 'delphi_result', 'value');
end;

procedure TWebBrowser.RunJS(js: string);
var
  Doc: IHTMLDocument2;      // current HTML document
  HTMLWindow: IHTMLWindow2; // parent window of current HTML document
begin
  Doc:=IHTMLDocument2(Self.Document);

  if not Assigned(Doc) then
    Exit;

  HTMLWindow := Doc.parentWindow;
  if not Assigned(HTMLWindow) then
    Exit;

  try
    //JSFn := Format('foo("%s",%d)', [S, I]);  // build function call
    HTMLwindow.execScript(js, 'Javascript'); // execute function
  except
     //
  end;
end;

// Способ второй
uses
  SHDocVw;

procedure TForm2.FormCreate(Sender: TObject);
begin
  WebBrowser1.Navigate('http://www.decoding.dax.ru/');
end;

procedure TForm2.Button1Click(Sender: TObject);
begin
  WebBrowser1.Navigate('javascript: alert(document.title);');
end;

// или немного иначе

uses
  SHDocVw;

procedure TForm1.FormCreate(Sender: TObject);
// Содержимое загруженной страницы
// 
//    
//       
//    
//    
//       
//    
// 
begin
  WebBrowser1.Navigate('...');
end;

procedure TForm1.RunJava(const S: string);
var
  FName, Flags: OLEVariant;
begin
  FName := WideString(S);
  Flags := navNoHistory;
  WebBrowser1.Navigate(FName, Flags);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  RunJava('javascript:ShowMessage(''ddd'');');
end;

// Способ третий
uses
  SHDocVw, MSHTML;

procedure TForm2.FormCreate(Sender: TObject);
begin
  WebBrowser1.Navigate('http://www.decoding.dax.ru/');
end;

procedure TForm2.Button1Click(Sender: TObject);
var
  iDoc: IHtmlDocument2;
begin
  WebBrowser1.ControlInterface.Document.QueryInterface(IHTMLDocument2, iDoc);
  iDoc.parentWindow.execScript('alert(document.title)', 'JavaScript');
  iDoc := nil;
end;

// Способ четвертый
procedure TForm2.FormCreate(Sender: TObject);
begin
  WebBrowser1.Navigate('http://www.decoding.dax.ru/');
end;

procedure TForm2.Button1Click(Sender: TObject);
var
  Doc{, s}: Variant;
begin
  // Ссылка на документ.
  Doc := WebBrowser1.OleObject.document;
  // Проверка - существует ли документ.
  if TVarData(Doc).VDispatch = nil then
  begin
    ShowMessage('Объект документа не создан. Действие отменено.');
    Exit;
  end;

  Doc.parentWindow.alert(Doc.parentWindow.document.title);
  Doc := Unassigned;

 // Можно вызвать функцию anyFunction(),
 // определённую в скрипте на веб-странице.
 // s := Doc.parentWindow.getPageStatus();
 // ShowMessage(s);
end;

Как подавить вывод сообщений об ошибках сценария JavaScript в TWebBrowser?


WebBrowser1.Silent := True;
// Проверялось в Delphi 6 - не работает
// Проверялось в Delphi XE - работает

Как сохранить веб страничку в JPEG?


uses
  JPEG, ActiveX, ComObj;

implementation

procedure TForm1.FormCreate(Sender: TObject);
begin
  WebBrowser1.Navigate('http://www.decoding.dax.ru');
end;

procedure generateJPEGfromBrowser(Browser: iWebBrowser2; JpegFileName: string;
  srcWidth, srcHeight: Integer);
var
  SourceDrawRect: TRect;
  SourceBitmap: TBitmap;
  Jpeg: TJPEGImage;
  ViewObject: IViewObject;
begin
  SourceBitmap := TBitmap.Create;
  Jpeg := TJPEGImage.Create;

  try
    try
      SourceDrawRect := Rect(0, 0, srcWidth, srcHeight);
      SourceBitmap.Width := srcWidth;
      SourceBitmap.Height := srcHeight;

      ViewObject := Browser as IViewObject;

      if ViewObject = nil then
        Exit;

      OleCheck(ViewObject.Draw(DVASPECT_CONTENT, 1, nil, nil, Form1.Handle,
        SourceBitmap.Canvas.Handle, @SourceDrawRect, nil, nil, 0));

      // Create a Jpeg from the Bitmap and save it
      Jpeg.Assign(SourceBitmap);
      Jpeg.CompressionQuality := 80;

      Jpeg.SaveToFile(JpegFileName);
    finally
      Jpeg.Free;
      SourceBitmap.Free;
    end;
  except
    // Error Code
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  tmpX, tmpY: Integer;
begin
  with WebBrowser1 do
  begin
    tmpX := Height;
    tmpY := Width;
    LockWindowUpdate(Form1.Handle);
    TControl(WebBrowser1).Visible := False;
    Width := OleObject.Document.body.scrollWidth {+ 25};
    if Width < 1200 then
       Width := 1200;
    Height := OleObject.Document.body.scrollHeight;
    generateJPEGfromBrowser(ControlInterface, 'd:\test.jpg', Width, Height);
    Height := tmpX;
    Width := tmpY;
    TControl(WebBrowser1).Visible := True;
    LockWindowUpdate(0);
  end;
end;

Как обработать OnClick у TWebBrowser?


uses
  OleCtrls, SHDocVw;

type
  TForm1 = class(TForm)
    WebBrowser1: TWebBrowser;
    procedure FormCreate(Sender: TObject);
  private
    procedure MyMessages(var Msg: TMsg; var Handled: Boolean);
  public
  end;

implementation

procedure TForm1.FormCreate(Sender: TObject);
begin
  WebBrowser1.Navigate('http://decoding.dax.ru');
  Application.OnMessage := MyMessages;
end;

procedure TForm1.MyMessages(var Msg: TMsg; var Handled: Boolean);
var
  X, Y: Integer;
  // Document, E: OleVariant;
begin
  Handled := False;
  if (WebBrowser1 = nil) or (Msg.message <> WM_LBUTTONDOWN) then
    Exit;

  Handled := IsDialogMessage(WebBrowser1.Handle, Msg);

  if Handled then
  begin
    case Msg.message of
      WM_LBUTTONDOWN: begin
        X := LOWORD(Msg.lParam);
        Y := HIWORD(Msg.lParam);
        // Document := WebBrowser1.Document;
        // E := Document.elementFromPoint(X, Y);
        ShowMessage('x = ' + IntToStr(X) + ', y  = ' + IntToStr(Y) + #13 +
                    'You clicked on:' + #13 );// + E.outerHTML);
       end;
    end;
  end;
end;

Как отключить/включить отображение рисунков в TWebBrowser?


uses
  SHDocVw, OleCtrls, ActiveX;

type
  TWebBrowser = class(SHDocVw.TWebBrowser, IDispatch)
  private
    FImageEnabled: Boolean;
    procedure SetImageEnabled(const Value: Boolean);
  protected
    function IDispatch.Invoke = Invoke;
    function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
     Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall;
  public
    constructor Create(AOwner: TComponent); override;
  published
    property ImageEnabled: boolean read FImageEnabled write SetImageEnabled default True;
  end;

  TForm1 = class(TForm)
    MainMenu1: TMainMenu;
    N11: TMenuItem;
    N12: TMenuItem;
    WebBrowser1: TWebBrowser;
    procedure FormCreate(Sender: TObject);
    procedure N12Click(Sender: TObject);
  private
  public
  end;

implementation

{ TWebBrowser }

constructor TWebBrowser.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FImageEnabled := True;
end;

function TWebBrowser.Invoke(DispID: Integer; const IID: TGUID;
  LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo,
  ArgErr: Pointer): HResult;
const
  DISPID_AMBIENT_DLCONTROL = -5512;
  DLCTL_DLIMAGES = $00000010;
begin
  if (Flags and DISPATCH_PROPERTYGET <> 0) and (VarResult <> nil) then
  begin
    Result := S_OK;
    case DispID of
      DISPID_AMBIENT_DLCONTROL:
        if FImageEnabled then
          PVariant(VarResult)^ := Integer(DLCTL_DLIMAGES)
        else
          PVariant(VarResult)^ := Integer(not DLCTL_DLIMAGES);
    else
      Result := DISP_E_MEMBERNOTFOUND;
    end;
  end
  else
    Result := inherited Invoke(DispID, IID, LocaleID, Flags, Params,
                               VarResult, ExcepInfo, ArgErr);
end;

procedure TWebBrowser.SetImageEnabled(const Value: Boolean);
var
  Path: OleVariant;
begin
  if Assigned(Document) then
  begin
    FImageEnabled := Value;
    Path := OleObject.document.location;
    RecreateWnd;
    Navigate(Path);
  end;
end;

{ TForm1 }

procedure TForm1.FormCreate(Sender: TObject);
begin
  WebBrowser1.ImageEnabled := True;   // Это тут.
  WebBrowser1.Navigate('http://decoding.dax.ru');
end;

procedure TForm1.N12Click(Sender: TObject);
begin
  WebBrowser1.ImageEnabled := not WebBrowser1.ImageEnabled;
end;

Как обрабатывать нажаите клавиш в TWebBrowser?


uses
  SHDocVw, OleCtrls, ActiveX;

type
  TForm1 = class(TForm)
    WebBrowser1: TWebBrowser;
    procedure FormCreate(Sender: TObject);
    procedure FormActivate(Sender: TObject);
    procedure FormDeactivate(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
  private
    FOleInPlaceActiveObject: IOleInPlaceActiveObject;
    SaveMessageHandler: TMessageEvent;
    procedure MyMessageHandler(var Msg: TMsg; var Handled: Boolean);
  public
  end;

implementation

procedure TForm1.FormCreate(Sender: TObject);
begin
  WebBrowser1.Navigate('http://decoding.dax.ru');
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  Application.OnMessage := SaveMessageHandler;
  FOleInPlaceActiveObject := nil;
end;

procedure TForm1.FormActivate(Sender: TObject);
begin
  SaveMessageHandler := Application.OnMessage;
  Application.OnMessage := MyMessageHandler;
end;

procedure TForm1.FormDeactivate(Sender: TObject);
begin
  Application.OnMessage := SaveMessageHandler;
end;

procedure TForm1.MyMessageHandler(var Msg: TMsg; var Handled: Boolean);
var
  iOIPAO: IOleInPlaceActiveObject;
  Dispatch: IDispatch;
begin
  {exit if we don't get back a webbrowser object}
  if WebBrowser1 = nil then
  begin
    Handled := False;
    Exit;
  end;

  Handled := IsDialogMessage(WebBrowser1.Handle, Msg) = True;

  if Handled and (not WebBrowser1.Busy) then
  begin
    if FOleInPlaceActiveObject = nil then
    begin
      Dispatch := WebBrowser1.Application;
      if Dispatch <> nil then
      begin
        Dispatch.QueryInterface(IOleInPlaceActiveObject, iOIPAO);
        if iOIPAO <> nil then
          FOleInPlaceActiveObject := iOIPAO;
      end;
    end;

    if FOleInPlaceActiveObject <> nil then
      if ((Msg.message = WM_KEYDOWN) or (Msg.message = WM_KEYUP)) and
         ((Msg.wParam = VK_BACK) or (Msg.wParam = VK_RETURN)) then
      begin
         // Здесь обрабатываем нажатие клавиш
      end
      else
        FOleInPlaceActiveObject.TranslateAccelerator(Msg);
  end;
end;

Как определить доступность операций GoBack и GoForward для TWebBrowse?


uses
  SHDocVw;

procedure TForm1.WebBrowser1CommandStateChange(ASender: TObject;
  Command: Integer; Enable: WordBool);
begin
  case Command of
    CSC_NAVIGATEBACK: BtnBack.Enabled := Enable;
    CSC_NAVIGATEFORWARD: Btn_Forward.Enabled := Enable;
  end;
end;

Как скрыть/показать полосы прокртки в TWebBrowser?


// Способ первый
procedure TForm1.WB_HideScrollBar(Hide: Boolean);
begin
  if Hide then
  begin
    WebBrowser1.OleObject.Document.Body.Style.OverflowX := 'hidden';
    WebBrowser1.OleObject.Document.Body.Style.OverflowY := 'hidden';
  end
  else
  begin
    WebBrowser1.OleObject.Document.Body.Style.OverflowX := '';
    WebBrowser1.OleObject.Document.Body.Style.OverflowY := '';
  end;
end;

// Способ второй
uses
  MSHTML;

procedure TForm1.Button1Click(Sender: TObject);
var
  lDocument: IHTMLDocument2;
  lBody: IHTMLElement;
  lStyle: IHTMLStyle2;
begin
  if Assigned(WebBrowser1.Document) and
     (Succeeded(WebBrowser1.Document.QueryInterface(IHTMLDocument2, lDocument))) then
  begin
    lBody := lDocument.Body;
    if Assigned(lBody) and Assigned(lBody.style) and
       Succeeded(lBody.Style.QueryInterface(IID_IHTMLStyle2, lStyle)) then
    begin
      lStyle.overflowX := 'hidden'; // Убираем горизонтальный скрол,
                                    // чтобы вернуть, нужно присвоить пустую строку
      lStyle.overflowY := 'hidden'; // Убираем вертикальный скрол
                                    // чтобы вернуть, нужно присвоить пустую строку
    end;
  end;
end;

Как скрыть/показать рамку у TWebBrowser?


procedure TForm1.WB_HideBorder(Hide: Boolean);
begin
  if Hide then
    WebBrowser1.OleObject.Document.Body.Style.borderStyle := 'none'
  else
    WebBrowser1.OleObject.Document.Body.Style.borderStyle := '';
end;

Как прокрутить страницу в TWebBrowser в самый низ?


procedure TForm1.Button1Click(Sender: TObject);
begin
  if WebBrowser1.ReadyState = READYSTATE_COMPLETE then
    WebBrowser1.OleObject.Document.ParentWindow.Scrollto(0, WebBrowser1.OleObject.document.body.scrollHeight);
end;

При использовании материала - ссылка на сайт обязательна