Ja przed chwilą przeprowadziłem testy przez znaleziony kod w google po wpisaniu delphi printing tform, znowu
się dziwie że autor wątku nie poświęcił nawet chwili. Ale do rzeczy. Przydługi kod zawarty na stronie o adresie:
http://www.delphifaq.com/faq/delphi/printing/f469.shtml drukuje formatkę jednak sposób pobierania obrazu,
w tym kodzie sprawie że na przykład pola edycyjne będą bez napisów. Dlatego wykorzystałem znalezony kod:
//...
procedure TForm1.ScreenShotForm(DestBitmap : TBitmap);
var
C : TCanvas;
H : THandle;
R, T : TRect;
begin
C := TCanvas.Create;
C.Handle := GetWindowDC(GetDesktopWindow);
H := Handle;
GetWindowRect(H, T);
try
R := Rect(0, 0, T.Right - T.Left, T.Bottom - T.Top);
DestBitmap.Width := T.Right - T.Left;
DestBitmap.Height := T.Bottom - T.Top;
DestBitmap.Canvas.CopyRect(R, C, T);
finally
ReleaseDC(0, C.Handle);
C.Free;
end;
end;
Który zapisuje do bitmapy całą zawartość formatki. Następnie zmieniona procedura z linku powyżej będzie tak
jak tutaj wklejam - wyglądać. Można poeksperymentować jeszcze z tym aby formatka nie miała paska albo w
ogóle jak zbędny pasek tytułowy to ustawić BorderStyle na bsNone. Zmiennymi ScaleX oraz ScaleY należy, po
testach - dopasować rozmiar na wydruku. Funkcja z podanym Canvasem drukarki używa w parametrach także
położenia rysunku bitmapy. Domyślnie na 0, 0 - to też sobie już jakoś sam dopasujesz. A oto i kod procedury:
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;
var
Bmp : TBitmap;
begin
Bmp := TBitmap.Create;
ScreenShotForm(Bmp);
{Get the screen dc}
DC := GetDC(0);
{Create a compatible dc}
MemDC := CreateCompatibleDC(DC);
{create a bitmap}
MemBitmap := Bmp.Handle;
Bmp.Free;
{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 * 4;
ScaleY := Self.Height * 4;
{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, 10, 10, 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;