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

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

:: Меню ::

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

:: FAQ ::

:: Заметки ::

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

:: Win API ::

:: Проекты ::

:: Скачать ::

:: Секреты ::

:: Ссылки ::

:: Сервис ::

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

:: MVP ::

:: RSS ::

Как проверить, является ли текущее соединение в TWebBrowser Secure (SSL)?


procedure TForm1.WebBrowser1DocumentComplete(Sender: TObject;
  const pDisp: IDispatch; var URL: OleVariant);
begin
   if ( Sender as TWebBrowser ).Oleobject.Document.Location.Protocol = 'https:' then
      Caption := 'Yes - Sichere Verbindung'
   else
      Caption := 'No - Unsichere Verbindung';
end;

Как сделать TWebBrowser плоским вместо 3D?


uses
  {...,} MSHTML;

procedure TForm1.WebBrowser1DocumentComplete(Sender: TObject;
  const pDisp: IDispatch; var URL: OleVariant);
const
  Make_Flat = true;
var
  Doc: IHTMLDocument2;
  Element: IHTMLElement;
begin
   Doc := IHTMLDocument2( TWebBrowser( Sender ).Document );
   if Doc = nil then
      Exit;
   Element := Doc.body;
   if Element = nil then
      Exit;
   case Make_Flat of
      true : Element.style.borderStyle := 'none';
      false : Element.style.borderStyle := '';
   end;
end;

Как скрыть контекстное меню у TWebBrowser?


var
  Form1: TForm1;
  HookID: THandle;

function MouseProc( nCode: Integer; wParam, lParam: Longint ): Longint; stdcall;
const
  IE_NAME = 'Internet Explorer_Server';
var
  szClassName: array[0..255] of Char;
begin
   case nCode < 0 of
      true: Result := CallNextHookEx( HookID, nCode, wParam, lParam )
      else
         case wParam of
            WM_RBUTTONDOWN, WM_RBUTTONUP:
            begin
               GetClassName( PMOUSEHOOKSTRUCT( lParam )^.HWND, szClassName,
                             SizeOf( szClassName ) );
               if lstrcmp( @szClassName[0], @IE_NAME[1] ) = 0 then
                  Result := HC_SKIP
               else
                  Result := CallNextHookEx( HookID, nCode, wParam, lParam );
            end
            else
               Result := CallNextHookEx( HookID, nCode, wParam, lParam );
         end;
   end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
   WebBrowser1.Navigate( 'http://decoding.dax.ru' );
   HookID := SetWindowsHookEx( WH_MOUSE, MouseProc, 0, GetCurrentThreadId );
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
   if HookID <> 0 then
      UnHookWindowsHookEx( HookID );
end;

Как сохранить исходник HTML из TWebBrowser.Document на диск?


// Способ первый
uses
  {...,} ActiveX;

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

procedure TForm1.SaveHTMLSourceToFile( FileName: string; WB: TWebBrowser );
var
  PersistStream: IPersistStreamInit;
  FileStream: TFileStream;
  Stream: IStream;
  SaveResult: HRESULT;
begin
   PersistStream := WB.Document as IPersistStreamInit;
   FileStream := TFileStream.Create( FileName, fmCreate );
   try
      Stream := TStreamAdapter.Create( FileStream, soReference ) as IStream;
      SaveResult := PersistStream.Save( Stream, true );
      if FAILED( SaveResult ) then
         MessageBox( Handle, 'Ошибка при сохранении HTML файла', 'Ошибка', 0 );
   finally
      FileStream.Free;
   end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
   if SaveDialog1.Execute then
      SaveHTMLSourceToFile( SaveDialog1.FileName, WebBrowser1 );
end;

// Способ второй
uses
  {...,} MSHTML, ActiveX;

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

procedure TForm1.Button1Click(Sender: TObject);
var
  HTMLDocument: IHTMLDocument2;
  PersistFile: IPersistFile;
begin
   if SaveDialog1.Execute then
   begin
      HTMLDocument := WebBrowser1.Document as IHTMLDocument2;
      PersistFile  := HTMLDocument as IPersistFile;
      PersistFile.Save( StringToOleStr( SaveDialog1.FileName ), System.True );
   end;
end;

// Способ третий
uses
  {...,} ActiveX;

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

function WB_SaveHTMLCode( WebBrowser: TWebBrowser; FileName: TFileName ): Boolean;
var
  ps: IPersistStreamInit;
  fs: TFileStream;
  sa: IStream;
begin
   ps := WebBrowser.Document as IPersistStreamInit;
   fs := TFileStream.Create( FileName, fmCreate );
   try
      sa := TStreamAdapter.Create( fs, soReference ) as IStream;
      Result := Succeeded( ps.Save( sa, true ) );
   finally
      fs.Free;
   end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
   WB_SaveHTMLCode( WebBrowser1, 'c:\test.txt' );
end;

Как сохранить HTML страницу из TWebBrowser.Document на диск вместе со всеми файлами (CSS, JPG, GIF и т.д.)?


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

procedure SaveHTMLSourceToFile( WB: TWebBrowser );
begin
   try
      WB.ExecWB( 4, 0 );
   except
      on E: Exception do
         E.Create( 'Ошибка при сохранении HTML файла' );
   end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
   SaveHTMLSourceToFile( WebBrowser1 );
end;

Как реализовать масштабирование страницы в TWebBrowser?


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

procedure TForm1.Button1Click(Sender: TObject);
begin
   WebBrowser1.OleObject.Document.Body.Style.Zoom := 0.75;
end;

// Zoom = 0.25 - 25% от оригинала
// Zoom = 0.5  - 50% от оригинала
// Zoom = 0.75 - 75% от оригинала
// Zoom = 1.0  - 100% от оригинала
// Zoom = 1.5  - 150% от оригинала
// Zoom = 2.0  - 200% от оригинала
// и так далее по аналогии

Как получить все линки из всех фреймов в TWebBrowser?


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

procedure TForm1.Button1Click(Sender: TObject);
var
  u: variant;
  v: IDispatch;
  s: string;

  procedure RecurseLinks( htmlDoc: variant );
  var
    BodyElement : variant;
    ElementCo: variant;
    HTMLFrames: variant;
    HTMLWnd : variant;
    j, i : integer;
  begin
     if VarIsEmpty( htmlDoc ) then
        Exit;
     BodyElement := htmlDoc.body;
     if BodyElement.tagName = 'BODY' then
     begin
        ElementCo := htmlDoc.links;
        j := ElementCo.Length-1;
        for i := 0 to j do
        begin
           u := ElementCo.item( i );
           s := u.href;
           ListBox1.Items.Add( s );
        end;
     end;
     HTMLFrames := htmlDoc.Frames;
     j := HTMLFrames.length-1;
     for i := 0 to j do
     begin
        HTMLWnd := HTMLFrames.Item( i );
        RecurseLinks( HTMLWnd.Document );
     end;
  end;

begin
   v := WebBrowser1.document;
   ListBox1.Clear;
   RecurseLinks( v );
end;

Как найти и подсветить текст в TWebBrowser?


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

procedure SearchAndHighlightText( WB: TWebBrowser; aText: string );
var 
  i: integer;
begin
   for i := 0 to WB.OleObject.Document.All.Length-1 do
   begin
      if Pos( aText, WB.OleObject.Document.All.Item( i ).InnerText ) <> 0 then
      begin
         WB.OleObject.Document.All.Item( i ).Style.Color := '#FFFF00';
         WB.OleObject.Document.All.Item( i ).ScrollIntoView( true );
      end;
   end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
   SearchAndHighlightText( WebBrowser1, 'some text...' );
end;

// Способ второй
uses
  {...,} MSHTML;

type
  TForm1 = class(TForm)
  private
    procedure SearchAndHighlightText(aText: string);
  end;

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

procedure TForm1.SearchAndHighlightText(aText: string);
var
  tr: IHTMLTxtRange;
begin
   if not WebBrowser1.Busy then
   begin
      tr := ( ( WebBrowser1.Document as IHTMLDocument2 ).body as IHTMLBodyElement ).createTextRange;
      while tr.findText( aText, 1, 0 ) do
      begin
         tr.pasteHTML( '<span style="background-color: Lime; font-weight: bolder;">' +
            tr.htmlText + '</span>' );
         tr.scrollIntoView( true );
      end;
   end;
end;

Как перевести TWebBrowser в режим редактирования?


uses
  MSHTML;

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

procedure TForm1.WebBrowser1DocumentComplete(Sender: TObject;
  const pDisp: IDispatch; var URL: OleVariant);
var
  CurrentWB: IWebBrowser;
begin
   CurrentWB := pDisp as IWebBrowser;
   ( CurrentWB.Document as IHTMLDocument2 ).DesignMode := 'On';
end;

// Некоторые клавиши, доступные в режиме редактирования:
// Ctrl + C - Копировать
// Ctrl + X - Вырезать
// Ctrl + V - Вставить
// Ctrl + B - Жирный текст
// Ctrl + I - Наклонный текст
// Ctrl + U - Подчеркнутый текст
// Ctrl + Z - Отменить
// Ctrl + Y - Повторить
// Ctrl + K - Гиперссылка
// Ctrl + F - Найти 
// Ctrl + A - Выделить всё 
// Ctrl + LeftMouseButtonClick - Выделить блок

Как показать диалог свойств TWebBrowser?


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

procedure TForm1.Button1Click(Sender: TObject);
var
  eQuery: OLECMDF;
  vaIn, vaOut: OleVariant;
begin
   try
      eQuery := Webbrowser1.QueryStatusWB( OLECMDID_PROPERTIES );
      if ( eQuery and OLECMDF_ENABLED ) = OLECMDF_ENABLED then
         Webbrowser1.ExecWB( OLECMDID_PROPERTIES, OLECMDEXECOPT_PROMPTUSER, vaIn, vaOut );
   except
   end;
end;

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

procedure TForm1.Button1Click(Sender: TObject);
begin
   try
      WebBrowser1.ExecWB( OLECMDID_PROPERTIES, OLECMDEXECOPT_PROMPTUSER );
   except
   end;
end;

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