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;

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