Mega Code Archive
Printing a tform
<![CDATA[
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.
procedure TForm1.PrintForm;
var
DC: HDC;
isDcPalDevice: Bool;
MemDC: HDC;
MemBitmap: HBITMAP;
OldMemBitmap: HBITMAP;
hDibHeader: THandle;
pDibHeader: Pointer;
hBits: THandle;
pBits: Pointer;
ScaleX: Double;
ScaleY: Double;
pPal: PLOGPALETTE;
pal: HPALETTE;
OldPal: HPALETTE;
i: Integer;
begin
{Get the screen dc}
DC := GetDC(0);
{Create a compatible dc}
MemDC := CreateCompatibleDC(DC);
{create a bitmap}
MemBitmap := CreateCompatibleBitmap(DC, Self.Width, Self.Height);
{select the bitmap into the dc}
OldMemBitmap := SelectObject(MemDC, MemBitmap);
{Lets prepare to try a fixup for broken video drivers}
isDcPalDevice := False;
if GetDeviceCaps(DC, RASTERCAPS) and RC_PALETTE=RC_PALETTE then
begin
GetMem(pPal, SizeOf(TLOGPALETTE)+(255*SizeOf(TPALETTEENTRY)));
FillChar(pPal^, SizeOf(TLOGPALETTE)+(255*SizeOf(TPALETTEENTRY)),
#0);
pPal^.palVersion := $300;
pPal^.palNumEntries := GetSystemPaletteEntries(DC, 0, 256, pPal^.palPalEntry);
if pPal^.palNumEntries<>0 then
begin
pal := CreatePalette(pPal^);
OldPal := SelectPalette(MemDC, pal, False);
isDcPalDevice := True
end
else
FreeMem(pPal, SizeOf(TLOGPALETTE)+(255*SizeOf(TPALETTEENTRY)));
end;
{copy from the screen to the memdc/bitmap}
BitBlt(MemDC, 0, 0, Self.Width, Self.Height, DC, Self.Left, Self.Top, SRCCOPY);
if isDcPalDevice=True then
begin
SelectPalette(MemDC, OldPal, False);
DeleteObject(pal);
end;
{unselect the bitmap}
SelectObject(MemDC, OldMemBitmap);
{delete the memory dc}
DeleteDC(MemDC);
{Allocate memory for a DIB structure}
hDibHeader := GlobalAlloc(GHND, SizeOf(TBITMAPINFO)+(SizeOf(TRGBQUAD)*
256));
{get a pointer to the alloced memory}
pDibHeader := GlobalLock(hDibHeader);
{fill in the dib structure with info on the way we want the DIB}
FillChar(pDibHeader^, SizeOf(TBITMAPINFO)+(SizeOf(TRGBQUAD)*
256), #0);
PBITMAPINFOHEADER(pDibHeader)^.biSize := SizeOf(TBITMAPINFOHEADER);
PBITMAPINFOHEADER(pDibHeader)^.biPlanes := 1;
PBITMAPINFOHEADER(pDibHeader)^.biBitCount := 8;
PBITMAPINFOHEADER(pDibHeader)^.biWidth := Self.Width;
PBITMAPINFOHEADER(pDibHeader)^.biHeight := Self.Height;
PBITMAPINFOHEADER(pDibHeader)^.biCompression := BI_RGB;
{find out how much memory for the bits}
GetDIBits(DC, MemBitmap, 0, Self.Height, nil, TBITMAPINFO(pDibHeader^),
DIB_RGB_COLORS);
{Alloc memory for the bits}
hBits := GlobalAlloc(GHND, PBITMAPINFOHEADER(pDibHeader)^.BiSizeImage);
{Get a pointer to the bits}
pBits := GlobalLock(hBits);
{Call fn again, but this time give us the bits!}
GetDIBits(DC, MemBitmap, 0, Self.Height, pBits, PBitmapInfo(pDibHeader)^,
DIB_RGB_COLORS);
{Lets try a fixup for broken video drivers}
if isDcPalDevice=True then
begin
for i := 0 to (pPal^.palNumEntries-1) do
begin
PBitmapInfo(pDibHeader)^.bmiColors[i].rgbRed := pPal^.palPalEntry[i].peRed;
PBitmapInfo(pDibHeader)^.bmiColors[i].rgbGreen := pPal^.palPalEntry[i].peGreen;
PBitmapInfo(pDibHeader)^.bmiColors[i].rgbBlue := pPal^.palPalEntry[i].peBlue;
end;
FreeMem(pPal, SizeOf(TLOGPALETTE)+(255*SizeOf(TPALETTEENTRY)));
end;
{Release the screen dc}
ReleaseDC(0, DC);
{Delete the bitmap}
DeleteObject(MemBitmap);
{Start print job}
Printer.BeginDoc;
{Scale print size }
ScaleX := Self.Width*3;
ScaleY := Self.Height*3;
{
if Printer.PageWidth < Printer.PageHeight then
begin
ScaleX := Printer.PageWidth;
ScaleY := Self.Height*(Printer.PageWidth/Self.Width);
end
else
begin
ScaleX := Self.Width*(Printer.PageHeight/Self.Height);
ScaleY := Printer.PageHeight;
end;
}
{Just incase the printer drver is a palette device}
isDcPalDevice := False;
if GetDeviceCaps(Printer.Canvas.Handle, RASTERCAPS) and RC_PALETTE=RC_PALETTE
then
begin
{Create palette from dib}
GetMem(pPal, SizeOf(TLOGPALETTE)+(255*SizeOf(TPALETTEENTRY)));
FillChar(pPal^, SizeOf(TLOGPALETTE)+(255*SizeOf(TPALETTEENTRY)),
#0);
pPal^.palVersion := $300;
pPal^.palNumEntries := 256;
for i := 0 to (pPal^.palNumEntries-1) do
begin
pPal^.palPalEntry[i].peRed := PBitmapInfo(pDibHeader)^.bmiColors[i].rgbRed;
pPal^.palPalEntry[i].peGreen := PBitmapInfo(pDibHeader)^.bmiColors[i].rgbGreen;
pPal^.palPalEntry[i].peBlue := PBitmapInfo(pDibHeader)^.bmiColors[i].rgbBlue;
end;
pal := CreatePalette(pPal^);
FreeMem(pPal, SizeOf(TLOGPALETTE)+(255*SizeOf(TPALETTEENTRY)));
OldPal := SelectPalette(Printer.Canvas.Handle, pal, False);
isDcPalDevice := True
end;
{send the bits to the printer}
StretchDiBits(Printer.Canvas.Handle, 0, 0, Round(ScaleX), Round(ScaleY),
0, 0, Self.Width, Self.Height, pBits, PBitmapInfo(pDibHeader)^,
DIB_RGB_COLORS, SRCCOPY);
{Just incase you printer drver is a palette device}
if isDcPalDevice=True then
begin
SelectPalette(Printer.Canvas.Handle, OldPal, False);
DeleteObject(pal);
end;
{Clean up allocated memory}
GlobalUnlock(hBits);
GlobalFree(hBits);
GlobalUnlock(hDibHeader);
GlobalFree(hDibHeader);
{end the print job}
Printer.EndDoc;
end;
]]>