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