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;
|
