Обновлено: 02 декабря, 2018

Невидимый браузер TWebBrowser в потоке в Delphi

Ниже приведены несколько примеров создания браузера в потоке.

Пример 1

unit Unit1;
 
interface
 
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, StdCtrls,
  ActiveX, OleCtrls, SHDocVw, MSHTML;
 
type
  PWebBrowserContainer = ^TWebBrowserContainer;

TWebBrowserContainer = record
    Handle: HWND;
    WebBrowser: IWebBrowser2;
    Created: THandle;
  end;
 
type
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    Button3: TButton;
    procedure Button2Click(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
  private
    FWebBrowserContainer1: TWebBrowserContainer;
  end;
 
var
  Form1: TForm1;
 
implementation
 
{$R *.dfm}
 
const
  CLSID_InternetExplorer: TGUID = '{8856F961-340A-11D0-A96B-00C04FD705A2}';
 
function AtlAxAttachControl(const pControl: IUnknown;
  hWnd: HWND; ppUnkContainer: IUnknown): DWORD; stdcall; external 'ATL.DLL';
 
{******************************************************************************}
 
const
  CMD_NAVIGATE = 1;
 
type
  TWebBrowserCommandResultCallback = procedure(Result: Pointer);
 
type
  PWebBrowserCommand = ^TWebBrowserCommand;
  TWebBrowserCommand = record
    Number: Integer;
    Parameter: Pointer;
    ResultCallback: TWebBrowserCommandResultCallback;
  end;
 
function MsgOnlyWindowProc(hwnd: HWND; uMsg: UINT;
  wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall;
var
  Container: PWebBrowserContainer;
  Command: PWebBrowserCommand;
begin
  case uMsg of
    WM_USER:     
    begin
      Container := PWebBrowserContainer(wParam);
      Command := PWebBrowserCommand(lParam);
 
      case Command^.Number of
 
        CMD_NAVIGATE:
        begin      
          Container^.WebBrowser.Navigate(PAnsiChar(Command^.Parameter), EmptyParam, EmptyParam, EmptyParam, EmptyParam);
          while (Container^.WebBrowser.ReadyState <> READYSTATE_COMPLETE) do
          begin
            Application.ProcessMessages();
            Sleep(1);
          end;
          Command^.ResultCallback(PWideChar((Container^.WebBrowser.Document as IHTMLDocument2).body.outerHTML));
        end;
 
      end;
    end;
  else
    Result := DefWindowProc(hwnd, uMsg, wParam, lParam);
    Exit;
  end;
  Result := 1;
end;
 
function NewMsgOnlyThreadProc(Container: PWebBrowserContainer): DWORD; stdcall;
var
  WndClass: TWndClassEx;
  Msg: TMsg;
begin
  FillChar(WndClass, SizeOf(WndClass), 0);
  with WndClass do
  begin
    cbSize := SizeOf(WndClass);
    lpszClassName := 'MESSAGE_ONLY_WINDOW';
    lpfnWndProc := @MsgOnlyWindowProc;
  end;
  RegisterClassEx(WndClass);
 
  Container^.Handle := CreateWindowEx(0, WndClass.lpszClassName, nil,
    0, 0, 0, 0, 0, 0, 0, 0, nil);
  //Container^.Handle := CreateWindowEx(0, WndClass.lpszClassName, nil,
  //  0, 0, 0, 0, 0, HWND_MESSAGE, 0, 0, nil);
  if (Container^.Handle = 0) then
    raise Exception.Create('CreateWindowEx');
  try
 
    CoInitializeEx(nil, COINIT_APARTMENTTHREADED);
 
    if (CoCreateInstance(CLSID_InternetExplorer, nil, CLSCTX_INPROC_SERVER,
      IID_IWebBrowser2, Container^.WebBrowser) <> S_OK) then
      raise Exception.Create('CoCreateInstance');
    try
 
      AtlAxAttachControl(Container^.WebBrowser, Container^.Handle, nil);
 
      SetEvent(Container^.Created);
      while (WaitForSingleObject(Container^.Created, 0) = WAIT_OBJECT_0) do
      begin
        while PeekMessage(Msg, Container^.Handle, 0, 0, PM_REMOVE) do
        begin
          TranslateMessage(Msg);
          DispatchMessage(Msg);
        end;
        Sleep(1);
      end;
 
    finally
      Container^.WebBrowser := nil;
    end;
   
  finally
    DestroyWindow(Container^.Handle);
    SetEvent(Container^.Created);
  end;
 
  Result := 0;
end;
 
procedure CreateWebBrowserContainer(out Container: TWebBrowserContainer);
var
  ForegroundWindow: HWND;
  NewThreadId: DWORD;
  NewThreadHandle: THandle;
begin
  ForegroundWindow := GetForegroundWindow(); 
  Container.Created := CreateEvent(nil, True, False, nil);
  NewThreadHandle := CreateThread(nil, 0, @NewMsgOnlyThreadProc,
    @Container, 0, NewThreadId);
  if (NewThreadHandle <> 0) then
    CloseHandle(NewThreadHandle);
  WaitForSingleObject(Container.Created, INFINITE);
  SetForegroundWindow(ForegroundWindow);
end;
 
procedure DestroyWebBrowserContainer(var Container: TWebBrowserContainer);
begin
  ResetEvent(Container.Created);
  WaitForSingleObject(Container.Created, INFINITE);
  CloseHandle(Container.Created);
end;
 
procedure SendCommandToWebBrowser(const Container: TWebBrowserContainer; Command: PWebBrowserCommand);
begin
  SendMessage(Container.Handle, WM_USER, WPARAM(@Container), LPARAM(Command));
end;
 
{******************************************************************************}
 
procedure TForm1.Button1Click(Sender: TObject);
begin
  CreateWebBrowserContainer(FWebBrowserContainer1);
end;
 
procedure TForm1.Button2Click(Sender: TObject);
begin
  DestroyWebBrowserContainer(FWebBrowserContainer1);
end;
 
procedure ResultCallback(text: PWideChar);
begin
  MessageBoxW(0, text, 'Result', MB_OK);
end;
 
procedure TForm1.Button3Click(Sender: TObject);
var
  Command: TWebBrowserCommand;
begin
  Command.Number := CMD_NAVIGATE;
  Command.Parameter := PAnsiChar('http://ya.ru');
  Command.ResultCallback := @ResultCallback;
  SendCommandToWebBrowser(FWebBrowserContainer1, @Command);
end;
 
end.

Скачать исходник можно здесь.

Пример 2

unit WBPages2;
interface
{var
  FURLString: string;
  wb: IWebBrowser2; // бразуер
  wHandle: HWND; // handle созданного окна
}
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, StdCtrls,
  ActiveX, OleCtrls, SHDocVw, MSHTML, HttpApp;
var
  wb: IWebBrowser2; // бразуер
  wHandle: HWND; // handle созданного окна
function GetWBHtml2(url: String): String;
implementation
const
  CLSID_InternetExplorer: TGUID = '{8856F961-340A-11D0-A96B-00C04FD705A2}';
function AtlAxAttachControl(const pControl: IUnknown;
  hWnd: HWND; ppUnkContainer: IUnknown): DWORD; stdcall; external 'ATL.DLL';
function GetWBHtml2(url: String): String;
var
  WndClass: TWndClassEx;
  pData: OleVariant;
  Msg: tagMSG;
  HTMLDocument: IHTMLDocument2;
  PersistFile: IPersistFile;
  ss: TStringStream;
  PersistStream: IPersistStreamInit;
  Stream: IStream;
  res: String;
begin
  FillChar(WndClass, SizeOf(WndClass), 0);
  with WndClass do
  begin
    cbSize := SizeOf(WndClass);
    lpszClassName := 'MESSAGE_ONLY_WINDOW';
    lpfnWndProc := @DefWindowProc;
  end;
  RegisterClassEx(WndClass);
  wHandle := CreateWindowEx(0, WndClass.lpszClassName, nil,
    0, 0, 0, 0, 0, DWORD(HWND_MESSAGE), 0, 0, nil);
  if (wHandle = 0) then
    raise Exception.Create('CreateWindowEx');
  try
    CoInitializeEx(nil, COINIT_APARTMENTTHREADED);
    if (CoCreateInstance(CLSID_InternetExplorer, nil, CLSCTX_INPROC_SERVER,
      IID_IWebBrowser2, wb) <> S_OK) then
      raise Exception.Create('CoCreateInstance');
    try
      AtlAxAttachControl(wb, wHandle, nil);
      pData := EmptyParam;
      wb.Navigate(url, EmptyParam, EmptyParam, pData, EmptyParam) ;
      while (wb.ReadyState <> READYSTATE_COMPLETE) do
      begin
        while PeekMessage(Msg, 0, 0, 0, PM_REMOVE) do
          DispatchMessage(Msg);
        Sleep(1);
      end;
      {HTMLDocument := wb.Document as IHTMLDocument2;
      PersistFile := HTMLDocument as IPersistFile;
      PersistFile.Save(StringToOleStr('WBPages2_'+
        FormatDateTime('yyyy-mm-dd-hh-mm-ss-zzz', Now)+'.htm'), True);}
      HTMLDocument := (wb.Document) as IHTMLDocument2;
      PersistStream := HTMLDocument as IPersistStreamInit;
      ss := TStringStream.Create;
      try
        Stream := TStreamAdapter.Create(ss, soReference) as IStream;
        PersistStream.Save(Stream, True);
        //Result := ss.DataString;
        Result := StringOf(TEncoding.Convert(TEncoding.UTF8,
          TEncoding.GetEncoding(1251), BytesOf(ss.DataString)));
      finally
        ss.Free;
      end;
      //MessageBoxW(0, PWideChar((wb.Document as IHTMLDocument2).title), '', 0);
    finally
      wb := nil;
    end;
  finally
    DestroyWindow(wHandle);
  end;
end;
end.

Пример 3

procedure TWPThread.Execute;
var
  WndClass: TWndClassEx;
begin
  FillChar(WndClass, SizeOf(WndClass), 0);
  with WndClass do
  begin
    cbSize := SizeOf(WndClass);
    lpszClassName := 'MESSAGE_ONLY_WINDOW';
    lpfnWndProc := @DefWindowProc;
  end;
  RegisterClassEx(WndClass);
 
  wHandle := CreateWindowEx(0, WndClass.lpszClassName, nil,
    0, 0, 0, 0, 0, DWORD(HWND_MESSAGE), 0, 0, nil);
  if (wHandle = 0) then
    raise Exception.Create('CreateWindowEx');
 
  try
 
    CoInitializeEx(nil, COINIT_APARTMENTTHREADED);
 
    if (CoCreateInstance(CLSID_InternetExplorer, nil, CLSCTX_INPROC_SERVER,
      IID_IWebBrowser2, wb) <> S_OK) then
      raise Exception.Create('CoCreateInstance');
    try
 
      AtlAxAttachControl(wb, wHandle, nil);
 
      wb.Navigate('http://ya.ru', EmptyParam, EmptyParam, EmptyParam, EmptyParam) ;
 
      while (wb.ReadyState <> READYSTATE_COMPLETE) do
      begin
        while PeekMessage(Msg, 0, 0, 0, PM_REMOVE) do DispatchMessage(Msg);
        Sleep(1);
      end;
 
      MessageBoxW(0, PWideChar((wb.Document as IHTMLDocument2).title), '', 0);
 
    finally
      wb := nil;
    end;
 
  finally
    DestroyWindow(wHandle);
  end;
end;

Пример 4

uses
  ActiveX, MSHTML, Variants;
 
const
  CLSID_HTMLDocument: TCLSID = '{25336920-03F9-11CF-8FD0-00AA00686F13}';
  CLSID_MHTMLDocument: TCLSID = '{3050F3D9-98B5-11CF-BB82-00AA00BDCE0B}';
 
procedure TForm1.Button1Click(Sender: TObject);
var
  HtmlDoc: IHTMLDocument2;
  HtmlText: Variant;
begin
  // надо расскомментировать, если код будет выполняться в отдельном потоке
  // CoInitializeEx(nil, COINIT_APARTMENTTHREADED);
    
  if (CoCreateInstance(CLSID_HTMLDocument, nil, CLSCTX_INPROC_SERVER,
    IID_IHTMLDocument2, HtmlDoc) <> S_OK) then
    raise Exception.Create('Cannot initialize HTMLDocument.');
          
  HtmlText := VarArrayCreate([0, 0], varVariant);
  HtmlText[0] := WideString('<html><head><title>Vasya</title></head><body &#111;&#110;load="alert(''blabla'')"></body></html>');
  HtmlDoc.write(PSafeArray(TVarData(HtmlText).VArray));
  HtmlDoc.close();
  
  // делаем что хотим с HtmlDoc
  // ...
  MessageBoxW(Handle, PWideChar(HtmlDoc.title), '', MB_OK);
  // ...
 
  // CoUninitialize();
end;

Рейтинг автора

Автор статьи

Юрий

Программист Delphi, MySQL. Образование: высшее. Специальность: программное обеспечение информационных технологий.

Написано статей

439