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

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

:: Меню ::

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

:: FAQ ::

:: Заметки ::

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

:: Win API ::

:: Проекты ::

:: Скачать ::

:: Секреты ::

:: Ссылки ::

:: Сервис ::

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

:: MVP ::

:: RSS ::

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


uses
  MSHTML;

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), True);
  end;
end;

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

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 и т.д.)?


uses
  MSHTML;

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?


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

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?


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

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;

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