Articles   Members Online:
-Article/Tip Search
-News Group Search over 21 Million news group articles.
-Delphi/Pascal
-CBuilder/C++
-C#Builder/C#
-JBuilder/Java
-Kylix
Member Area
-Home
-Account Center
-Top 10 NEW!!
-Submit Article/Tip
-Forums Upgraded!!
-My Articles
-Edit Information
-Login/Logout
-Become a Member
-Why sign up!
-Newsletter
-Chat Online!
-Indexes NEW!!
Employment
-Build your resume
-Find a job
-Post a job
-Resume Search
Contacts
-Contacts
-Feedbacks
-Link to us
-Privacy/Disclaimer
Embarcadero
Visit Embarcadero
Embarcadero Community
JEDI
Links
How to create and print a screen shot of a TForm Turn on/off line numbers in source code. Switch to Orginial background IDE or DSP color Comment or reply to this aritlce/tip for discussion. Bookmark this article to my favorite article(s). Print this article
07-Oct-02
Category
Reporting /Printing
Language
Delphi 2.x
Views
80
User Rating
No Votes
# Votes
0
Replies
0
Publisher:
DSP, Administrator
Reference URL:
DKB
			Author: Jonas Bilinkevicius

How to create and print a screen shot of a TForm

Answer:

The following details a better way to print the contents of a form, by getting the 
device independent bits in 256 colors from the form, and using those bits to print 
the form to the printer.

In addition, a check is made to see if the screen or printer is a palette device, 
and if so, palette handling for the device is enabled. If the screen device is a 
palette device, an additional step is taken to fill the bitmap's palette from the 
system palette, overcoming some buggy video drivers who don't fill the palette in.

Note: Since this code does a screen shot of the form, the form must be the topmost 
window and the whole from must be viewable when the form shot is made.

1   unit Prntit;
2   
3   interface
4   
5   uses
6     SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms,
7     Dialogs, StdCtrls, ExtCtrls;
8   
9   type
10    TForm1 = class(TForm)
11      Button1: TButton;
12      Image1: TImage;
13      procedure Button1Click(Sender: TObject);
14    private
15      { Private declarations }
16    public
17      { Public declarations }
18    end;
19  
20  var
21    Form1: TForm1;
22  
23  implementation
24  
25  {$R *.DFM}
26  
27  uses
28    Printers;
29  
30  procedure TForm1.Button1Click(Sender: TObject);
31  var
32    dc: HDC;
33    isDcPalDevice: BOOL;
34    MemDc: HDC;
35    MemBitmap: hBitmap;
36    OldMemBitmap: hBitmap;
37    hDibHeader: THandle;
38    pDibHeader: pointer;
39    hBits: THandle;
40    pBits: pointer;
41    ScaleX: Double;
42    ScaleY: Double;
43    ppal: PLOGPALETTE;
44    pal: hPalette;
45    Oldpal: hPalette;
46    i: integer;
47  begin
48    {Get the screen dc}
49    dc := GetDc(0);
50    {Create a compatible dc}
51    MemDc := CreateCompatibleDc(dc);
52    {create a bitmap}
53    MemBitmap := CreateCompatibleBitmap(Dc, form1.width, form1.height);
54    {select the bitmap into the dc}
55    OldMemBitmap := SelectObject(MemDc, MemBitmap);
56    {Lets prepare to try a fixup for broken video drivers}
57    isDcPalDevice := false;
58    if GetDeviceCaps(dc, RASTERCAPS) and RC_PALETTE = RC_PALETTE then
59    begin
60      GetMem(pPal, sizeof(TLOGPALETTE) + (255 * sizeof(TPALETTEENTRY)));
61      FillChar(pPal^, sizeof(TLOGPALETTE) + (255 * sizeof(TPALETTEENTRY)), #0);
62      pPal^.palVersion := $300;
63      pPal^.palNumEntries := GetSystemPaletteEntries(dc, 0, 256, pPal^.palPalEntry);
64      if pPal^.PalNumEntries <> 0 then
65      begin
66        pal := CreatePalette(pPal^);
67        oldPal := SelectPalette(MemDc, Pal, false);
68        isDcPalDevice := true
69      end
70      else
71        FreeMem(pPal, sizeof(TLOGPALETTE) + (255 * sizeof(TPALETTEENTRY)));
72    end;
73    {copy from the screen to the memdc/ bitmap}
74    BitBlt(MemDc, 0, 0, form1.width, form1.height, Dc, form1.left, form1.top, 
75  SrcCopy);
76    if isDcPalDevice = true then
77    begin
78      SelectPalette(MemDc, OldPal, false);
79      DeleteObject(Pal);
80    end;
81    {unselect the bitmap}
82    SelectObject(MemDc, OldMemBitmap);
83    {delete the memory dc}
84    DeleteDc(MemDc);
85    {Allocate memory for a DIB structure}
86    hDibHeader := GlobalAlloc(GHND, sizeof(TBITMAPINFO) + (sizeof(TRGBQUAD) * 256));
87    {get a pointer to the alloced memory}
88    pDibHeader := GlobalLock(hDibHeader);
89    {fill in the dib structure with info on the way we want the DIB}
90    FillChar(pDibHeader^, sizeof(TBITMAPINFO) + (sizeof(TRGBQUAD) * 256), #0);
91    PBITMAPINFOHEADER(pDibHeader)^.biSize := sizeof(TBITMAPINFOHEADER);
92    PBITMAPINFOHEADER(pDibHeader)^.biPlanes := 1;
93    PBITMAPINFOHEADER(pDibHeader)^.biBitCount := 8;
94    PBITMAPINFOHEADER(pDibHeader)^.biWidth := form1.width;
95    PBITMAPINFOHEADER(pDibHeader)^.biHeight := form1.height;
96    PBITMAPINFOHEADER(pDibHeader)^.biCompression := BI_RGB;
97    {find out how much memory for the bits}
98    GetDIBits(dc, MemBitmap, 0, form1.height, nil, TBitmapInfo(pDibHeader^),
99      DIB_RGB_COLORS);
100   {Alloc memory for the bits}
101   hBits := GlobalAlloc(GHND, PBitmapInfoHeader(pDibHeader)^.BiSizeImage);
102   {Get a pointer to the bits}
103   pBits := GlobalLock(hBits);
104   {Call fn again, but this time give us the bits!}
105   GetDIBits(dc, MemBitmap, 0, form1.height, pBits, PBitmapInfo(pDibHeader)^,
106     DIB_RGB_COLORS);
107   {Lets try a fixup for broken video drivers}
108   if isDcPalDevice = true then
109   begin
110     for i := 0 to (pPal^.PalNumEntries - 1) do
111     begin
112       PBitmapInfo(pDibHeader)^.bmiColors[i].rgbRed := pPal^.palPalEntry[i].peRed;
113       PBitmapInfo(pDibHeader)^.bmiColors[i].rgbGreen := 
114 pPal^.palPalEntry[i].peGreen;
115       PBitmapInfo(pDibHeader)^.bmiColors[i].rgbBlue := pPal^.palPalEntry[i].peBlue;
116     end;
117     FreeMem(pPal, sizeof(TLOGPALETTE) + (255 * sizeof(TPALETTEENTRY)));
118   end;
119   {Release the screen dc}
120   ReleaseDc(0, dc);
121   {Delete the bitmap}
122   DeleteObject(MemBitmap);
123   {Start print job}
124   Printer.BeginDoc;
125   {Scale print size}
126   if Printer.PageWidth < Printer.PageHeight then
127   begin
128     ScaleX := Printer.PageWidth;
129     ScaleY := Form1.Height * (Printer.PageWidth / Form1.Width);
130   end
131   else
132   begin
133     ScaleX := Form1.Width * (Printer.PageHeight / Form1.Height);
134     ScaleY := Printer.PageHeight;
135   end;
136   {Just in case the printer driver is a palette device}
137   isDcPalDevice := false;
138   if GetDeviceCaps(Printer.Canvas.Handle, RASTERCAPS) and
139     RC_PALETTE = RC_PALETTE then
140   begin
141     {Create palette from dib}
142     GetMem(pPal, sizeof(TLOGPALETTE) + (255 * sizeof(TPALETTEENTRY)));
143     FillChar(pPal^, sizeof(TLOGPALETTE) + (255 * sizeof(TPALETTEENTRY)), #0);
144     pPal^.palVersion := $300;
145     pPal^.palNumEntries := 256;
146     for i := 0 to (pPal^.PalNumEntries - 1) do
147     begin
148       pPal^.palPalEntry[i].peRed := PBitmapInfo(pDibHeader)^.bmiColors[i].rgbRed;
149       pPal^.palPalEntry[i].peGreen := 
150 PBitmapInfo(pDibHeader)^.bmiColors[i].rgbGreen;
151       pPal^.palPalEntry[i].peBlue := PBitmapInfo(pDibHeader)^.bmiColors[i].rgbBlue;
152     end;
153     pal := CreatePalette(pPal^);
154     FreeMem(pPal, sizeof(TLOGPALETTE) + (255 * sizeof(TPALETTEENTRY)));
155     oldPal := SelectPalette(Printer.Canvas.Handle, Pal, false);
156     isDcPalDevice := true
157   end;
158   {send the bits to the printer}
159   StretchDiBits(Printer.Canvas.Handle, 0, 0, Round(scaleX), Round(scaleY), 0, 0,
160     Form1.Width, Form1.Height, pBits, PBitmapInfo(pDibHeader)^,
161     DIB_RGB_COLORS, SRCCOPY);
162   {Just in case you printer driver is a palette device}
163   if isDcPalDevice = true then
164   begin
165     SelectPalette(Printer.Canvas.Handle, oldPal, false);
166     DeleteObject(Pal);
167   end;
168   {Clean up allocated memory}
169   GlobalUnlock(hBits);
170   GlobalFree(hBits);
171   GlobalUnlock(hDibHeader);
172   GlobalFree(hDibHeader);
173   {End the print job}
174   Printer.EndDoc;
175 end;


			
Vote: How useful do you find this Article/Tip?
Bad Excellent
1 2 3 4 5 6 7 8 9 10

 

Advertisement
Share this page
Advertisement
Download from Google

Copyright © Mendozi Enterprises LLC