?
Solved

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

Posted on 2009-04-29
20
Medium Priority
?
815 Views
Last Modified: 2013-11-23
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
Comment
Question by:lucavilla
  • 11
  • 8
20 Comments
 
LVL 12

Expert Comment

by:Hypo
ID: 24267804
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
 
LVL 26

Accepted Solution

by:
Eddie Shipman earned 2000 total points
ID: 24271713
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
 

Author Comment

by:lucavilla
ID: 24272437
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
What does it mean to be "Always On"?

Is your cloud always on? With an Always On cloud you won't have to worry about downtime for maintenance or software application code updates, ensuring that your bottom line isn't affected.

 
LVL 26

Expert Comment

by:Eddie Shipman
ID: 24274414
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
 
LVL 26

Expert Comment

by:Eddie Shipman
ID: 24274580
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
 

Author Comment

by:lucavilla
ID: 24274638
Thanks EddieShipman!

Hypo, do you have anything to add or you agree with EddieShipman?
0
 
LVL 26

Expert Comment

by:Eddie Shipman
ID: 24280519
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
 

Author Comment

by:lucavilla
ID: 24287396
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
 
LVL 26

Expert Comment

by:Eddie Shipman
ID: 24287418
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
 

Author Closing Comment

by:lucavilla
ID: 31576181
I needed to do it necessariliy with hidden browser
0
 
LVL 26

Expert Comment

by:Eddie Shipman
ID: 24287478
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
 

Author Comment

by:lucavilla
ID: 24287614
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
 

Author Comment

by:lucavilla
ID: 24303259
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
 
LVL 26

Expert Comment

by:Eddie Shipman
ID: 24304384
I will take a look at it. It may be that the timing or the AJAX that Google Maps uses is the issue.
0
 

Author Comment

by:lucavilla
ID: 24304524
Thanks Eddie
0
 
LVL 26

Expert Comment

by:Eddie Shipman
ID: 24304887
I have no idea what is causing that one. I've tried everything I know to get it with no luck.
0
 
LVL 26

Expert Comment

by:Eddie Shipman
ID: 24304894
Please tell me more about the sites you want to capture.
0
 
LVL 26

Expert Comment

by:Eddie Shipman
ID: 24305117
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
 
LVL 26

Expert Comment

by:Eddie Shipman
ID: 24305352
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
 

Author Comment

by:lucavilla
ID: 24305889
Passed to the developer. Thanks!
I'll let you know.
0

Featured Post

Concerto's Cloud Advisory Services

Want to avoid the missteps to gaining all the benefits of the cloud? Learn more about the different assessment options from our Cloud Advisory team.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Creating an auto free TStringList The TStringList is a basic and frequently used object in Delphi. On many occasions, you may want to create a temporary list, process some items in the list and be done with the list. In such cases, you have to…
Introduction I have seen many questions in this Delphi topic area where queries in threads are needed or suggested. I know bumped into a similar need. This article will address some of the concepts when dealing with a multithreaded delphi database…
This Micro Tutorial will teach you how to add a cinematic look to any film or video out there. There are very few simple steps that you will follow to do so. This will be demonstrated using Adobe Premiere Pro CS6.
With just a little bit of  SQL and VBA, many doors open to cool things like synchronize a list box to display data relevant to other information on a form.  If you have never written code or looked at an SQL statement before, no problem! ...  give i…
Suggested Courses
Course of the Month16 days, 7 hours left to enroll

862 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question