Author: Tomas Rutkauskas
Printing a TForm
Answer:
If you try to print a Delphi form with the Print() method, it will print but the
page is blank.
Instead use the following method.
1 procedure TForm1.PrintForm;
2 var
3 DC: HDC;
4 isDcPalDevice: Bool;
5 MemDC: HDC;
6 MemBitmap: HBITMAP;
7 OldMemBitmap: HBITMAP;
8 hDibHeader: THandle;
9 pDibHeader: Pointer;
10 hBits: THandle;
11 pBits: Pointer;
12 ScaleX: Double;
13 ScaleY: Double;
14 pPal: PLOGPALETTE;
15 pal: HPALETTE;
16 OldPal: HPALETTE;
17 i: Integer;
18 begin
19 {Get the screen dc}
20 DC := GetDC(0);
21 {Create a compatible dc}
22 MemDC := CreateCompatibleDC(DC);
23 {create a bitmap}
24 MemBitmap := CreateCompatibleBitmap(DC, Self.Width, Self.Height);
25 {select the bitmap into the dc}
26 OldMemBitmap := SelectObject(MemDC, MemBitmap);
27
28 {Lets prepare to try a fixup for broken video drivers}
29 isDcPalDevice := False;
30 if GetDeviceCaps(DC, RASTERCAPS) and RC_PALETTE = RC_PALETTE then
31 begin
32 GetMem(pPal, SizeOf(TLOGPALETTE) + (255 * SizeOf(TPALETTEENTRY)));
33 FillChar(pPal^, SizeOf(TLOGPALETTE) + (255 * SizeOf(TPALETTEENTRY)),
34 #0);
35 pPal^.palVersion := $300;
36 pPal^.palNumEntries := GetSystemPaletteEntries(DC, 0, 256, pPal^.palPalEntry);
37 if pPal^.palNumEntries <> 0 then
38 begin
39 pal := CreatePalette(pPal^);
40 OldPal := SelectPalette(MemDC, pal, False);
41 isDcPalDevice := True
42 end
43 else
44 FreeMem(pPal, SizeOf(TLOGPALETTE) + (255 * SizeOf(TPALETTEENTRY)));
45 end;
46 {copy from the screen to the memdc/bitmap}
47 BitBlt(MemDC, 0, 0, Self.Width, Self.Height, DC, Self.Left, Self.Top, SRCCOPY);
48
49 if isDcPalDevice = True then
50 begin
51 SelectPalette(MemDC, OldPal, False);
52 DeleteObject(pal);
53 end;
54 {unselect the bitmap}
55 SelectObject(MemDC, OldMemBitmap);
56 {delete the memory dc}
57 DeleteDC(MemDC);
58 {Allocate memory for a DIB structure}
59 hDibHeader := GlobalAlloc(GHND, SizeOf(TBITMAPINFO) + (SizeOf(TRGBQUAD) *
60 256));
61 {get a pointer to the alloced memory}
62 pDibHeader := GlobalLock(hDibHeader);
63
64 {fill in the dib structure with info on the way we want the DIB}
65 FillChar(pDibHeader^, SizeOf(TBITMAPINFO) + (SizeOf(TRGBQUAD) *
66 256), #0);
67 PBITMAPINFOHEADER(pDibHeader)^.biSize := SizeOf(TBITMAPINFOHEADER);
68 PBITMAPINFOHEADER(pDibHeader)^.biPlanes := 1;
69 PBITMAPINFOHEADER(pDibHeader)^.biBitCount := 8;
70 PBITMAPINFOHEADER(pDibHeader)^.biWidth := Self.Width;
71 PBITMAPINFOHEADER(pDibHeader)^.biHeight := Self.Height;
72 PBITMAPINFOHEADER(pDibHeader)^.biCompression := BI_RGB;
73
74 {find out how much memory for the bits}
75 GetDIBits(DC, MemBitmap, 0, Self.Height, nil, TBITMAPINFO(pDibHeader^),
76 DIB_RGB_COLORS);
77
78 {Alloc memory for the bits}
79 hBits := GlobalAlloc(GHND, PBITMAPINFOHEADER(pDibHeader)^.BiSizeImage);
80
81 {Get a pointer to the bits}
82 pBits := GlobalLock(hBits);
83
84 {Call fn again, but this time give us the bits!}
85 GetDIBits(DC, MemBitmap, 0, Self.Height, pBits, PBitmapInfo(pDibHeader)^,
86 DIB_RGB_COLORS);
87
88 {Lets try a fixup for broken video drivers}
89 if isDcPalDevice = True then
90 begin
91 for i := 0 to (pPal^.palNumEntries - 1) do
92 begin
93 PBitmapInfo(pDibHeader)^.bmiColors[i].rgbRed := pPal^.palPalEntry[i].peRed;
94 PBitmapInfo(pDibHeader)^.bmiColors[i].rgbGreen :=
95 pPal^.palPalEntry[i].peGreen;
96 PBitmapInfo(pDibHeader)^.bmiColors[i].rgbBlue := pPal^.palPalEntry[i].peBlue;
97 end;
98 FreeMem(pPal, SizeOf(TLOGPALETTE) + (255 * SizeOf(TPALETTEENTRY)));
99 end;
100 {Release the screen dc}
101 ReleaseDC(0, DC);
102 {Delete the bitmap}
103 DeleteObject(MemBitmap);
104
105 {Start print job}
106 Printer.BeginDoc;
107
108 {Scale print size }
109 ScaleX := Self.Width * 3;
110 ScaleY := Self.Height * 3;
111
112 {
113 if Printer.PageWidth < Printer.PageHeight then
114 begin
115 ScaleX := Printer.PageWidth;
116 ScaleY := Self.Height*(Printer.PageWidth/Self.Width);
117 end
118 else
119 begin
120 ScaleX := Self.Width*(Printer.PageHeight/Self.Height);
121 ScaleY := Printer.PageHeight;
122 end;
123 }
124
125 {Just incase the printer drver is a palette device}
126 isDcPalDevice := False;
127 if GetDeviceCaps(Printer.Canvas.Handle, RASTERCAPS) and RC_PALETTE = RC_PALETTE
128 then
129 begin
130 {Create palette from dib}
131 GetMem(pPal, SizeOf(TLOGPALETTE) + (255 * SizeOf(TPALETTEENTRY)));
132 FillChar(pPal^, SizeOf(TLOGPALETTE) + (255 * SizeOf(TPALETTEENTRY)),
133 #0);
134 pPal^.palVersion := $300;
135 pPal^.palNumEntries := 256;
136 for i := 0 to (pPal^.palNumEntries - 1) do
137 begin
138 pPal^.palPalEntry[i].peRed := PBitmapInfo(pDibHeader)^.bmiColors[i].rgbRed;
139 pPal^.palPalEntry[i].peGreen :=
140 PBitmapInfo(pDibHeader)^.bmiColors[i].rgbGreen;
141 pPal^.palPalEntry[i].peBlue := PBitmapInfo(pDibHeader)^.bmiColors[i].rgbBlue;
142 end;
143 pal := CreatePalette(pPal^);
144 FreeMem(pPal, SizeOf(TLOGPALETTE) + (255 * SizeOf(TPALETTEENTRY)));
145 OldPal := SelectPalette(Printer.Canvas.Handle, pal, False);
146 isDcPalDevice := True
147 end;
148 {send the bits to the printer}
149 StretchDiBits(Printer.Canvas.Handle, 0, 0, Round(ScaleX), Round(ScaleY),
150 0, 0, Self.Width, Self.Height, pBits, PBitmapInfo(pDibHeader)^,
151 DIB_RGB_COLORS, SRCCOPY);
152
153 {Just incase you printer drver is a palette device}
154 if isDcPalDevice = True then
155 begin
156 SelectPalette(Printer.Canvas.Handle, OldPal, False);
157 DeleteObject(pal);
158 end;
159 {Clean up allocated memory}
160 GlobalUnlock(hBits);
161 GlobalFree(hBits);
162 GlobalUnlock(hDibHeader);
163 GlobalFree(hDibHeader);
164
165 {end the print job}
166 Printer.EndDoc;
167 end;
|
