• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 831
  • Last Modified:

to take a screenshot of a web page using an hidden window?

In a Delphi Windows application, is it possible to load a web page with the IE rendering engine in a hidden window and take a screenshot of that hidden page? if so, how?
0
lucavilla
Asked:
lucavilla
  • 11
  • 8
1 Solution
 
HypoCommented:
Hi,
it is possible to do what you want. Check out this article at delphi3000: http://www.delphi3000.com/articles/article_4132.asp?SK=

It describes how you capture the output from a TWebBrowser control to a Canvas handle, which is then saved to a jpeg file on disk. In the article, the WebBrowser control is on the main form, but you could easily change the code so that it paints a WebBrowser from a hidden window. I tried it myself and it worked fine. :)

NOTE:
I had to tweak the code in the example somewhat for it to work, for instance, I didn't have the unit MSHTML_TLB, but instead you can replace it with the unit MSHTML in the uses list. Also in the function TForm1.btnButton1Click, the web variable has the type ShDocVW_TLB.IWebBrowser2, but I didn't have ShDocVW_TLB, so that could just be replaced with IWebBrowser2, since it exists in the MSHTML unit. Orhter than that, it worked flawless. :)

regards
Hypo
0
 
Eddie ShipmanAll-around developerCommented:
Well, I don't think that TWebbrowser will allow you to navigate if it is not visible. I've tried it by placing it on a Panel and setting the Panel's Visible to False. I've tried it by having it in an invisible secondary form. Both would not allow WB to navigate and thus you can't take the screenshots.

The delphi3000.com article mentioned above doesn't show you how they actually navigate to the page you are trying to capture. Besides, using the viewObject does not handle pages that are larger that the viewable area of the webbrowser.

If you want to really try out something you can check out my post here:
http://www.delphipages.com/tips/thread.cfm?ID=292

It does FULL page screenshots but TWebbrowser needs to be visible.
0
 
lucavillaAuthor Commented:
EddieShipman, does you definition of "navigate" include the first opening page?
in other words, is it impossible to take the screenshot of a definite URL/page too? or only of subsequent pages following a navigation?
0
Free Tool: SSL Checker

Scans your site and returns information about your SSL implementation and certificate. Helpful for debugging and validating your SSL configuration.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

 
Eddie ShipmanAll-around developerCommented:
Yep, even about:blank, it will not do that either. I found that WB would not navigate to any URL if it was not visible.
Remember, it has to have a canvas to render to, right?

Let me try one more thing, however...
0
 
Eddie ShipmanAll-around developerCommented:
Well, I also tried moving the secondary form off the screen and still no luck.
Sorry, you are just going to have to show the webbrowser.
0
 
lucavillaAuthor Commented:
Thanks EddieShipman!

Hypo, do you have anything to add or you agree with EddieShipman?
0
 
Eddie ShipmanAll-around developerCommented:
Give this a try and see if it works for you.


unit Unit1;
 
interface
 
uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, MSHTML, StdCtrls, ExtCtrls, OleCtrls, SHDocVw, ComCtrls;
 
const
  IID_IHTMLElementRender: TGUID = '{3050F669-98B5-11CF-BB82-00AA00BDCE0B}';
 
type
  IHTMLElementRender = interface(IUnknown)
    ['{3050F669-98B5-11CF-BB82-00AA00BDCE0B}']
    function DrawToDC
      ( _hDC:                      HDC
      ): HResult; stdcall;
  end;
 
  TForm1 = class(TForm)
    PageControl1: TPageControl;
    TabSheet1: TTabSheet;
    TabSheet2: TTabSheet;
    wb: TWebBrowser;
    Panel1: TPanel;
    Panel2: TPanel;
    edtURL: TEdit;
    btnGet: TButton;
    ScrollBox1: TScrollBox;
    Image1: TImage;
    procedure wbDocumentComplete(Sender: TObject; const pDisp: IDispatch;
      var URL: OleVariant);
    procedure btnGetClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;
 
var
  Form1: TForm1;
 
implementation
 
{$R *.dfm}
 
function CreateWBSnapshot
  ( Browser:                   TWebBrowser
  ; OutputSize:                TPoint
  ): TBitmap;
var  pDoc:                     IHTMLDocument2;
     pElement:                 IHTMLElement2;
     pRender:                  IHTMLElementRender;
     bmpRender:                array [0..1] of TBitmap;
     dwClientWidth:            Integer;
     dwClientHeight:           Integer;
     dwIndex:                  Integer;
     dwX:                      Integer;
     dwLastX:                  Integer;
     bDoneX:                   Boolean;
     dwY:                      Integer;
     dwLastY:                  Integer;
     bDoneY:                   Boolean;
begin
 
  // Create resulting image
  result:=TBitmap.Create;
 
  // Set size
  result.Width:=OutputSize.x;
  result.Height:=OutputSize.y;
 
  // Check browser document
  if Assigned(Browser.Document) and (Browser.Document.QueryInterface(IHTMLDocument2, pDoc) = S_OK) then
  begin
     // Lock update
     LockWindowUpdate(Browser.Handle);
     // Resource protection
     try
        // Check document body
        if Assigned(pDoc.Body) and (pDoc.Body.QueryInterface(IHTMLElement2, pElement) = S_OK) then
        begin
           // Resource protection
           try
              // Get the renderer
              if (pElement.QueryInterface(IID_IHTMLElementRender, pRender) = S_OK) then
              begin
                 // Resource protection
                 try
                    // Create images to blit the parts to
                    for dwIndex:=0 to 1 do
                    begin
                       bmpRender[dwIndex]:=TBitmap.Create;
                       bmpRender[dwIndex].Width:=pElement.scrollWidth;
                       bmpRender[dwIndex].Height:=pElement.scrollHeight;
                    end;
                    // Get client width and height
                    dwClientWidth:=OutputSize.x; //pElement.clientWidth;
                    dwClientHeight:=OutputSize.y; //pElement.clientHeight;
                    // Resource protection
                    try
                       // Set starting X variables
                       dwX:=pElement.scrollWidth;
                       dwLastX:=(-1);
                       bDoneX:=False;
                       // Loop while X not done
                       while not(bDoneX) do
                       begin
                          // Scroll
                          pElement.scrollLeft:=dwX;
                          // Get scroll
                          dwX:=pElement.scrollLeft;
                          // Check for (-1)
                          if (dwLastX = (-1)) then dwLastX:=dwX + dwClientWidth;
                          // Set starting Y variables
                          dwY:=pElement.scrollHeight;
                          dwLastY:=(-1);
                          bDoneY:=False;
                          // Loop while Y not done
                          while not(bDoneY) do
                          begin
                             // Scroll
                             pElement.scrollTop:=dwY;
                             // Get scroll
                             dwY:=pElement.scrollTop;
                             // Check for (-1)
                             if (dwLastY = (-1)) then dwLastY:=dwY + dwClientHeight;
                             // Draw to bitmap handle
                             if (pRender.DrawToDC(bmpRender[0].Canvas.Handle) = S_OK) then
                             begin
                                // Blit the image
                                BitBlt(bmpRender[1].Canvas.Handle, dwX, dwY, dwLastX-dwX, dwLastY-dwY, bmpRender[0].Canvas.Handle, 2, 2,SRCCOPY);
                             end;
                             // Update the Y variables
                             bDoneY:=(dwY = 0);
                             dwLastY:=dwY;
                             Dec(dwY, (dwClientHeight-4));
                          end;
                          // Update the X variables
                          bDoneX:=(dwX = 0);
                          dwLastX:=dwX;
                          Dec(dwX, (dwClientWidth-4));
                       end;
                       // Stretch draw the image to the resulting bitmap
                       StretchBlt(Result.Canvas.Handle, 0, 0, OutputSize.x, OutputSize.y, bmpRender[1].Canvas.Handle, 0, 0, bmpRender[1].Width, bmpRender[1].Height, SRCCOPY);
                    finally
                       // Free the bitmap
                       for dwIndex:=0 to 1 do FreeAndNil(bmpRender[dwIndex]);
                    end;
                 finally
                    // Release interface
                    pRender:=nil;
                 end;
              end;
           finally
              // Release interface
              pElement:=nil;
           end;
        end;
     finally
        // Unlock update
        LockWindowUpdate(0);
        // Release interface
        pDoc:=nil;
     end;
  end;
 
end;
 
procedure TForm1.btnGetClick
  ( Sender:                    TObject
  );
begin
  PageControl1.ActivePageIndex := 1;
  Screen.Cursor := crHourGlass;
  if Length(Trim(edtURL.Text)) > 0 then
  begin
    wb.Navigate(edtURL.Text);
  end
  else
    ShowMessage('URL can not be blank');
end;
 
procedure TForm1.wbDocumentComplete
  ( Sender:                    TObject
  ; const pDisp:               IDispatch
  ; var URL:                   OleVariant
  );
var
  pDoc:                        IHTMLDocument2;
  pElement:                    IHTMLElement2;
  x, y:                        Integer;
begin
  if URL <> 'about:blank' then
  begin
    pDoc     := wb.Document as IHTMLDocument2;
    pElement := pDoc.body as IHTMLElement2;
    y        := pElement.scrollHeight;
    x        := pElement.scrollWidth;
    Image1.Picture.Bitmap.Assign(CreateWBSnapshot(wb, Point(x, y)));
    Screen.Cursor := crDefault;
    PageControl1.ActivePageIndex := 0;
  end;
end;
 
procedure TForm1.FormCreate
  ( Sender:                    TObject
  );
begin
  wb.Navigate('about:blank');
end;
 
end.

Open in new window

0
 
lucavillaAuthor Commented:
Before trying it, could you please tell me what this code is supposed/hoped to do? it's supposed to take a screenshot of a webpage in  *hidden* state?
0
 
Eddie ShipmanAll-around developerCommented:
You've already been told that that is not possible with TWebbrowser.

This one has a pagecontrol and changes to the page with the webbrowser to navigate and when it is finished loading the page, it does the screenshot and then switches back.

Can you not see in the code what is happening?
0
 
lucavillaAuthor Commented:
I needed to do it necessariliy with hidden browser
0
 
Eddie ShipmanAll-around developerCommented:
OK, I have a solution for you and you should write a thank you note to Russell Libby for this.
(http://www.experts-exchange.com/Programming/Languages/Pascal/Delphi/Q_21665161.html#15491088)

The code below has a Webbrowser that is aligned alNone on a Panel with width=0/ height-0
so that makes the webbrowser reach it's readystate and thus being able to render.



{Unit Code}
unit Unit1;
 
interface
 
uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, MSHTML, StdCtrls, ExtCtrls, OleCtrls, SHDocVw, ComCtrls;
 
const
  IID_IHTMLElementRender: TGUID = '{3050F669-98B5-11CF-BB82-00AA00BDCE0B}';
 
type
  IHTMLElementRender = interface(IUnknown)
    ['{3050F669-98B5-11CF-BB82-00AA00BDCE0B}']
    function DrawToDC
      ( _hDC:                      HDC
      ): HResult; stdcall;
  end;
 
  TForm1 = class(TForm)
    wb: TWebBrowser;
    Panel1: TPanel;
    edtURL: TEdit;
    btnGet: TButton;
    ScrollBox1: TScrollBox;
    Image1: TImage;
    procedure wbDocumentComplete(Sender: TObject; const pDisp: IDispatch;
      var URL: OleVariant);
    procedure btnGetClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;
 
var
  Form1: TForm1;
 
implementation
 
{$R *.dfm}
 
function CreateWBSnapshot
  ( Browser:                   TWebBrowser
  ; OutputSize:                TPoint
  ): TBitmap;
var  pDoc:                     IHTMLDocument2;
     pElement:                 IHTMLElement2;
     pRender:                  IHTMLElementRender;
     bmpRender:                array [0..1] of TBitmap;
     dwClientWidth:            Integer;
     dwClientHeight:           Integer;
     dwIndex:                  Integer;
     dwX:                      Integer;
     dwLastX:                  Integer;
     bDoneX:                   Boolean;
     dwY:                      Integer;
     dwLastY:                  Integer;
     bDoneY:                   Boolean;
begin
 
  // Create resulting image
  result:=TBitmap.Create;
 
  // Set size
  result.Width:=OutputSize.x;
  result.Height:=OutputSize.y;
 
  // Check browser document
  if Assigned(Browser.Document) and (Browser.Document.QueryInterface(IHTMLDocument2, pDoc) = S_OK) then
  begin
     // Lock update
     LockWindowUpdate(Browser.Handle);
     // Resource protection
     try
        // Check document body
        if Assigned(pDoc.Body) and (pDoc.Body.QueryInterface(IHTMLElement2, pElement) = S_OK) then
        begin
           // Resource protection
           try
              // Get the renderer
              if (pElement.QueryInterface(IID_IHTMLElementRender, pRender) = S_OK) then
              begin
                 // Resource protection
                 try
                    // Create images to blit the parts to
                    for dwIndex:=0 to 1 do
                    begin
                       bmpRender[dwIndex]:=TBitmap.Create;
                       bmpRender[dwIndex].Width:=pElement.scrollWidth;
                       bmpRender[dwIndex].Height:=pElement.scrollHeight;
                    end;
                    // Get client width and height
                    dwClientWidth:=OutputSize.x; //pElement.clientWidth;
                    dwClientHeight:=OutputSize.y; //pElement.clientHeight;
                    // Resource protection
                    try
                       // Set starting X variables
                       dwX:=pElement.scrollWidth;
                       dwLastX:=(-1);
                       bDoneX:=False;
                       // Loop while X not done
                       while not(bDoneX) do
                       begin
                          // Scroll
                          pElement.scrollLeft:=dwX;
                          // Get scroll
                          dwX:=pElement.scrollLeft;
                          // Check for (-1)
                          if (dwLastX = (-1)) then dwLastX:=dwX + dwClientWidth;
                          // Set starting Y variables
                          dwY:=pElement.scrollHeight;
                          dwLastY:=(-1);
                          bDoneY:=False;
                          // Loop while Y not done
                          while not(bDoneY) do
                          begin
                             // Scroll
                             pElement.scrollTop:=dwY;
                             // Get scroll
                             dwY:=pElement.scrollTop;
                             // Check for (-1)
                             if (dwLastY = (-1)) then dwLastY:=dwY + dwClientHeight;
                             // Draw to bitmap handle
                             if (pRender.DrawToDC(bmpRender[0].Canvas.Handle) = S_OK) then
                             begin
                                // Blit the image
                                BitBlt(bmpRender[1].Canvas.Handle, dwX, dwY, dwLastX-dwX, dwLastY-dwY, bmpRender[0].Canvas.Handle, 2, 2,SRCCOPY);
                             end;
                             // Update the Y variables
                             bDoneY:=(dwY = 0);
                             dwLastY:=dwY;
                             Dec(dwY, (dwClientHeight-4));
                          end;
                          // Update the X variables
                          bDoneX:=(dwX = 0);
                          dwLastX:=dwX;
                          Dec(dwX, (dwClientWidth-4));
                       end;
                       // Stretch draw the image to the resulting bitmap
                       StretchBlt(Result.Canvas.Handle, 0, 0, OutputSize.x, OutputSize.y, bmpRender[1].Canvas.Handle, 0, 0, bmpRender[1].Width, bmpRender[1].Height, SRCCOPY);
                    finally
                       // Free the bitmap
                       for dwIndex:=0 to 1 do FreeAndNil(bmpRender[dwIndex]);
                    end;
                 finally
                    // Release interface
                    pRender:=nil;
                 end;
              end;
           finally
              // Release interface
              pElement:=nil;
           end;
        end;
     finally
        // Unlock update
        LockWindowUpdate(0);
        // Release interface
        pDoc:=nil;
     end;
  end;
 
end;
 
procedure TForm1.btnGetClick
  ( Sender:                    TObject
  );
begin
  Screen.Cursor := crHourGlass;
  if Length(Trim(edtURL.Text)) > 0 then
  begin
    wb.Navigate(edtURL.Text);
  end
  else
    ShowMessage('URL can not be blank');
end;
 
procedure TForm1.wbDocumentComplete
  ( Sender:                    TObject
  ; const pDisp:               IDispatch
  ; var URL:                   OleVariant
  );
var
  pDoc:                        IHTMLDocument2;
  pElement:                    IHTMLElement2;
  x, y:                        Integer;
begin
  if URL <> 'about:blank' then
  begin
    pDoc     := wb.Document as IHTMLDocument2;
    pElement := pDoc.body as IHTMLElement2;
    y        := pElement.scrollHeight;
    x        := pElement.scrollWidth;
    Image1.Picture.Bitmap.Assign(CreateWBSnapshot(wb, Point(x, y)));
    Screen.Cursor := crDefault;
  end;
end;
 
procedure TForm1.FormCreate
  ( Sender:                    TObject
  );
begin
  wb.Navigate('about:blank');
end;
 
end.
 
{DFM}
object Form1: TForm1
  Left = 331
  Top = 117
  Width = 783
  Height = 540
  Caption = 'Form1'
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  OldCreateOrder = False
  OnCreate = FormCreate
  PixelsPerInch = 96
  TextHeight = 13
  object Panel1: TPanel
    Left = 104
    Top = 8
    Width = 0
    Height = 0
    Caption = 'Panel1'
    TabOrder = 0
    object wb: TWebBrowser
      Left = 1
      Top = 1
      Width = 598
      Height = 798
      TabOrder = 0
      OnDocumentComplete = wbDocumentComplete
      ControlData = {
        4C000000CE3D00007A5200000000000000000000000000000000000000000000
        000000004C000000000000000000000001000000E0D057007335CF11AE690800
        2B2E126208000000000000004C0000000114020000000000C000000000000046
        8000000000000000000000000000000000000000000000000000000000000000
        00000000000000000100000000000000000000000000000000000000}
    end
  end
  object edtURL: TEdit
    Left = 24
    Top = 16
    Width = 169
    Height = 21
    TabOrder = 1
    Text = 'http://www.google.com'
  end
  object btnGet: TButton
    Left = 216
    Top = 16
    Width = 75
    Height = 25
    Caption = 'btnGet'
    TabOrder = 2
    OnClick = btnGetClick
  end
  object ScrollBox1: TScrollBox
    Left = 24
    Top = 64
    Width = 665
    Height = 393
    TabOrder = 3
    object Image1: TImage
      Left = 0
      Top = 0
      Width = 661
      Height = 389
      Align = alClient
      AutoSize = True
    end
  end
end

Open in new window

0
 
lucavillaAuthor Commented:
Thanks EddieShipman!
I passed it to my developer colleague who will test it one of the next days.
I'll surely thank you both if it works and I will award you last message.

0
 
lucavillaAuthor Commented:
My developer answered this: "it didn't work correctly. At least not with all pages. Some pages worked, but  the Google Maps you want to monitor didn't work with this solution."
0
 
Eddie ShipmanAll-around developerCommented:
I will take a look at it. It may be that the timing or the AJAX that Google Maps uses is the issue.
0
 
lucavillaAuthor Commented:
Thanks Eddie
0
 
Eddie ShipmanAll-around developerCommented:
I have no idea what is causing that one. I've tried everything I know to get it with no luck.
0
 
Eddie ShipmanAll-around developerCommented:
Please tell me more about the sites you want to capture.
0
 
Eddie ShipmanAll-around developerCommented:
Using IViewObject works somewhat on Google Maps. There are still areas that aren't painted correctly.

In the code below, I use a button to take the snapshot and have a checkbox to use the IViewObject.
This code saves the snapshots to a file.

var
  sourceBitmap: TBitmap;
  sourceDrawRect: TRect;
  viewObject: IViewObject;
  Doc: IHTMLDocument2;
  body: OleVariant;
  intHeight, intWidth: Integer;
begin
  sourceBitmap           := TBitmap.Create;
  Doc                    := wb.Document as IHTMLDocument2;
  body                   := Doc.Body;
  intWidth               := body.ScrollWidth + body.LeftMargin + body.RightMargin;
  intHeight              := body.ScrollHeight + body.TopMargin + body.BottomMargin;
  wb.Width               := intWidth;
  wb.Height              := intHeight;
  try
    if chkIViewObject.Checked then
    begin
      body.NoWrap            := True;
      {hide scrollbars}
      body.Style.BorderStyle := 'none';
      body.Scroll            := 'no';
      sourceDrawRect         := Rect(0, 0, intWidth, intHeight);
      sourceBitmap.Width     := wb.Width;
      sourceBitmap.Height    := wb.Height;
 
      wb.Document.QueryInterface(IViewObject, ViewObject);
      if ViewObject <> nil then
      begin
        try
          ViewObject.Draw(DVASPECT_CONTENT, 1, nil, nil, Self.Handle,
            sourceBitmap.Canvas.Handle, @sourceDrawRect, nil, nil, 0);
        finally
          ViewObject._Release;
        end;
      end;
    end
    else
    begin
      sourcebitmap.Assign(CreateWBSnapshot(wb, Point(intWidth, intHeight)));
    end;
  finally
    sourceBitmap.SaveToFile('c:\aaa.bmp');
    sourceBitmap.Free;
  end;
end;

Open in new window

0
 
Eddie ShipmanAll-around developerCommented:
Ok, I think I may have found something. Take a look at the comments in this unit that I posted on Delphi Pages back in 2005.  All you have to do is include this unit and modify the form code I posted above like shown below.
It may be that the Google Maps pages needed to get the Parent .vs the Body to correctly render.

I did some tests and it seems to work.
{Modified form code}
unit Unit1;
 
interface
 
uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, MSHTML, StdCtrls, ExtCtrls, OleCtrls, SHDocVw, ComCtrls;
 
type
  TForm1 = class(TForm)
    wb: TWebBrowser;
    Panel1: TPanel;
    edtURL: TEdit;
    btnGet: TButton;
    ScrollBox1: TScrollBox;
    Image1: TImage;
    procedure wbDocumentComplete(Sender: TObject; const pDisp: IDispatch;
      var URL: OleVariant);
    procedure btnGetClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;
 
var
  Form1: TForm1;
 
implementation
 
uses WebUtils;
 
{$R *.dfm}
 
procedure TForm1.btnGetClick
  ( Sender:                    TObject
  );
begin
  Screen.Cursor := crHourGlass;
  if Length(Trim(edtURL.Text)) > 0 then
  begin
    wb.Navigate(edtURL.Text);
  end
  else
    ShowMessage('URL can not be blank');
end;
 
procedure TForm1.wbDocumentComplete
  ( Sender:                    TObject
  ; const pDisp:               IDispatch
  ; var URL:                   OleVariant
  );
var
  pDoc:                        IHTMLDocument2;
  pElement:                    IHTMLElement2;
  x, y:                        Integer;
begin
  if URL <> 'about:blank' then
  begin
    Image1.Picture.Bitmap.Assign(CreateScaledImage(wb, 1.0));
    Screen.Cursor := crDefault;
  end;
end;
 
procedure TForm1.FormCreate
  ( Sender:                    TObject
  );
begin
  wb.Navigate('about:blank');
end;
 
end.
 
{WebUtils unit}
unit WebUtils;
////////////////////////////////////////////////////////////////////////////////
//
//   Unit        :  WebUtils
//   Date        :  10.27.2005 (updated 10.28.2005)
//   Description :  Utility functions based on the TWebBrowser object
//
//
//   function GetDocumentSize(Browser: TWebBrowser): TPoint;
//
//      Returns the document's body size as a TPoint, where X = width and Y = height
//
//   function GetBrowserElement(Browser: TWebBrowser; out Element: IHTMLElement2): HResult;
//
//      Returns the actual element required to perform the rendering to a canvas handle.
//      For most pages, this will be the body element. But for some, eg:
//
//         http://www.experts-exchange.com
//         http://www.msn.com
//
//      the parent element will need to be used. The element to use is based on
//      getting the parent and checking it for a clientwidth/height of zero. If zero,
//      then the body element can be used. If not zero, then the parent must be used.
//
//   function CreateThumbnailImage(Browser: TWebBrowser; OutputSize: TPoint): TBitmap;
//
//      Returns a bitmap object of the document page where the width and height is
//      determined by the point (x = width, y=height) passed in OutputSize.
//
//   function CreateScaledImage(Browser: TWebBrowser; Scale: Double): TBitmap;
//
//      Returns a scaled bitmap object of the document page. A scaling of 1.0 will
//      return the page at its actual size. To return a 1/10 scaled image of the
//      document for example, 0.1 would be passed to Scale.
//
////////////////////////////////////////////////////////////////////////////////
interface
 
////////////////////////////////////////////////////////////////////////////////
//   Include units
////////////////////////////////////////////////////////////////////////////////
uses
  Windows, SysUtils, Classes, Graphics, ShdocVW, ActiveX, MSHTML;
 
////////////////////////////////////////////////////////////////////////////////
//   Constants
////////////////////////////////////////////////////////////////////////////////
const
  IID_IHTMLElementRender: TGUID =  '{3050F669-98B5-11CF-BB82-00AA00BDCE0B}';
////////////////////////////////////////////////////////////////////////////////
//   Interfaces
////////////////////////////////////////////////////////////////////////////////
type
  IHTMLElementRender   =  interface(IUnknown)
     ['{3050F669-98B5-11CF-BB82-00AA00BDCE0B}']
     function DrawToDC(_hDC: HDC): HResult; stdcall;
     function SetDocumentPrinter(const bstrPrinterName: WideString; _hDC: HDC): HResult; stdcall;
  end;
 
////////////////////////////////////////////////////////////////////////////////
//   Utility functions
////////////////////////////////////////////////////////////////////////////////
function   GetDocumentSize(Browser: TWebBrowser): TPoint;
function   GetBrowserElement(Browser: TWebBrowser; out Element: IHTMLElement2): HResult;
function   CreateThumbnailImage(Browser: TWebBrowser; OutputSize: TPoint): TBitmap;
function   CreateScaledImage(Browser: TWebBrowser; Scale: Double): TBitmap;
 
implementation
 
function GetBrowserElement(Browser: TWebBrowser; out Element: IHTMLElement2): HResult;
var  pDoc:          IHTMLDocument2;
     pElemParent:   IHTMLElement;
     pElement:      IHTMLElement;
     pElement2:     IHTMLElement2;
begin
 
  // Check browser document
  if Assigned(Browser.Document) then
  begin
     // QI for document 2 interface
     result:=Browser.Document.QueryInterface(IHTMLDocument2, pDoc);
     // Check result
     if Succeeded(result) then
     begin
        // Resource protection
        try
           // Check document body
           if Assigned(pDoc.Body) then
           begin
              // QI for body element
              result:=pDoc.Body.QueryInterface(IHTMLElement, pElement);
              // Check result
              if Succeeded(result) then
              begin
                 // Resource protection
                 try
                    // Get parent element
                    pElemParent:=pElement.parentElement;
                    // Check parent
                    if Assigned(pElemParent) then
                    begin
                       // Resource protection
                       try
                          // Get the element 2 interface
                          if Succeeded(pElemParent.QueryInterface(IHTMLElement2, pElement2)) then
                          begin
                             // Check parent interface for zero client width or height
                             if (pElement2.clientWidth = 0) or (pElement2.clientHeight = 0) then
                                // QI for element 2 interface
                                result:=pElement.QueryInterface(IHTMLElement2, Element)
                             else
                                // We have the element we are after
                                Element:=pElement2;
                          end
                          else
                             // QI for element 2 interface
                             result:=pElement.QueryInterface(IHTMLElement2, Element);
                       finally
                          // Release the interface
                          pElemParent:=nil;
                       end;
                    end
                    else
                       // Return nearest COM error
                       result:=E_NOINTERFACE;
                 finally
                    // Release the interface
                    pElement:=nil;
                 end;
              end;
           end
           else
              // Return nearest COM error
              result:=E_NOINTERFACE;
        finally
           // Release the interface
           pDoc:=nil;
        end;
     end;
  end
  else
     // Return nearest COM error
     result:=E_NOINTERFACE;
 
end;
 
function GetDocumentSize(Browser: TWebBrowser): TPoint;
var  pElement:      IHTMLElement2;
begin
 
  // Get the browser body element interface
  if Succeeded(GetBrowserElement(Browser, pElement)) then
  begin
     // Resource protection
     try
        // Set result size
        result:=Point(pElement.ScrollWidth, pElement.ScrollHeight);
     finally
        // Release the interface
        pElement:=nil;
     end;
  end
 
end;
 
function CreateScaledImage(Browser: TWebBrowser; Scale: Double): TBitmap;
var  ptActual:      TPoint;
     ptScale:       TPoint;
begin
 
  // Get actual size
  ptActual:=GetDocumentSize(Browser);
 
  // Apply the scaling to it
  ptScale.x:=Round(ptActual.x * Scale);
  ptScale.y:=Round(ptActual.y * Scale);
 
  // Get the image
  result:=CreateThumbnailImage(Browser, ptScale);
 
end;
 
function CreateThumbnailImage(Browser: TWebBrowser; OutputSize: TPoint): TBitmap;
var  pElement:      IHTMLElement2;
     pRender:       IHTMLElementRender;
     bmpRender:     Array [0..1] of TBitmap;
     dwClientWidth: Integer;
     dwClientHeight:Integer;
     dwIndex:       Integer;
     dwX:           Integer;
     dwLastX:       Integer;
     bDoneX:        Boolean;
     dwY:           Integer;
     dwLastY:       Integer;
     bDoneY:        Boolean;
begin
 
  // Create resulting image
  result:=TBitmap.Create;
 
  // Set size
  result.Width:=OutputSize.x;
  result.Height:=OutputSize.y;
 
  // Lock update
  LockWindowUpdate(Browser.Handle);
 
  // Resource protection
  try
     // Get the browser body element interface
     if Succeeded(GetBrowserElement(Browser, pElement)) then
     begin
        // Resource protection
        try
           // Get the renderer
           if Succeeded(pElement.QueryInterface(IID_IHTMLElementRender, pRender)) then
           begin
              // Resource protection
              try
                 // Create images to blit the parts to
                 for dwIndex:=0 to 1 do
                 begin
                    bmpRender[dwIndex]:=TBitmap.Create;
                    bmpRender[dwIndex].Width:=pElement.scrollWidth;
                    bmpRender[dwIndex].Height:=pElement.scrollHeight;
                 end;
                 // Set render "printer"
                 pRender.SetDocumentPrinter('Bitmap', bmpRender[0].Canvas.Handle);
                 // Get client width and height
                 dwClientWidth:=pElement.clientWidth;
                 dwClientHeight:=pElement.clientHeight;
                 // Resource protection
                 try
                    // Set starting X variables
                    dwX:=pElement.scrollWidth;
                    dwLastX:=(-1);
                    bDoneX:=False;
                    // Loop while X not done
                    while not(bDoneX) do
                    begin
                       // Scroll
                       pElement.scrollLeft:=dwX;
                       // Get scroll
                       dwX:=pElement.scrollLeft;
                       // Check for (-1)
                       if (dwLastX = (-1)) then dwLastX:=dwX + dwClientWidth;
                       // Set starting Y variables
                       dwY:=pElement.scrollHeight;
                       dwLastY:=(-1);
                       bDoneY:=False;
                       // Loop while Y not done
                       while not(bDoneY) do
                       begin
                          // Scroll
                          pElement.scrollTop:=dwY;
                          // Get scroll
                          dwY:=pElement.scrollTop;
                          // Check for (-1)
                          if (dwLastY = (-1)) then dwLastY:=dwY + dwClientHeight;
                          // Draw to bitmap handle
                          if (pRender.DrawToDC(bmpRender[0].Canvas.Handle) = S_OK) then
                          begin
                             // Blit the image
                             BitBlt(bmpRender[1].Canvas.Handle, 
                                    dwX, dwY, dwLastX-dwX, 
                                    dwLastY-dwY, 
                                    bmpRender[0].Canvas.Handle, 
                                    2, 2,SRCCOPY);
                          end;
                          // Update the Y variables
                          bDoneY:=(dwY = 0);
                          dwLastY:=dwY;
                          Dec(dwY, (dwClientHeight-4));
                       end;
                       // Update the X variables
                       bDoneX:=(dwX = 0);
                       dwLastX:=dwX;
                       Dec(dwX, (dwClientWidth-4));
                    end;
                    // Stretch draw the image to the resulting bitmap
                    StretchBlt(result.Canvas.Handle, 
                               0, 0, OutputSize.x, 
                               OutputSize.y, 
                               bmpRender[1].Canvas.Handle,  
                               0, 0, bmpRender[1].Width, 
                               bmpRender[1].Height, 
                               SRCCOPY);
                 finally
                    // Free the bitmap
                    for dwIndex:=0 to 1 do FreeAndNil(bmpRender[dwIndex]);
                 end;
              finally
                 // Release the interface
                 pRender:=nil;
              end;
           end;
        finally
           // Release the interfaces
           pElement:=nil;
        end;
     end;
  finally
     // Unlock update
     LockWindowUpdate(0);
  end;
end;
 
end.

Open in new window

0
 
lucavillaAuthor Commented:
Passed to the developer. Thanks!
I'll let you know.
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

Join & Write a Comment

Featured Post

Cloud Class® Course: Microsoft Windows 7 Basic

This introductory course to Windows 7 environment will teach you about working with the Windows operating system. You will learn about basic functions including start menu; the desktop; managing files, folders, and libraries.

  • 11
  • 8
Tackle projects and never again get stuck behind a technical roadblock.
Join Now