[Back to DELPHI SWAG index] [Back to Main SWAG index] [Original]

    The following TI 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.

    unit Prntit;

    interface

    uses
      SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics,
      Controls, Forms, Dialogs, StdCtrls, ExtCtrls;

    type
      TForm1 = class(TForm)
        Button1: TButton;
        Image1: TImage;
        procedure Button1Click(Sender: TObject);
      private
        { Private declarations }
      public
        { Public declarations }
      end;

    var
      Form1: TForm1;

    implementation

    {$R *.DFM}

    uses Printers;

    procedure TForm1.Button1Click(Sender: TObject);
    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,
                                          form1.width,
                                          form1.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,
             form1.width, form1.height,
             Dc,
             form1.left, form1.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 := form1.width;
      PBITMAPINFOHEADER(pDibHeader)^.biHeight := form1.height;
      PBITMAPINFOHEADER(pDibHeader)^.biCompression := BI_RGB;

     {find out how much memory for the bits}
      GetDIBits(dc,
                MemBitmap,
                0,
                form1.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,
                form1.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}
      if Printer.PageWidth < Printer.PageHeight then begin
       ScaleX := Printer.PageWidth;
       ScaleY := Form1.Height * (Printer.PageWidth / Form1.Width);
      end else begin
       ScaleX := Form1.Width * (Printer.PageHeight / Form1.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,
                    Form1.Width, Form1.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;

[Back to DELPHI SWAG index] [Back to Main SWAG index] [Original]