uses Printers;

type
  PPalEntriesArray = ^TPalEntriesArray; {for palette re-construction}
  TPalEntriesArray = array[0..0] of TPaletteEntry;

procedure BltTBitmapAsDib(DestDc: hdc; {Handle of where to blt}
  x: word; {Bit at x}
  y: word; {Blt at y}
  Width: word; {Width to stretch}
  Height: word; {Height to stretch}
  bm: TBitmap); {the TBitmap to Blt}
var
  OriginalWidth: LongInt; {width of BM}
  dc: hdc; {screen dc}
  IsPaletteDevice: bool; {if the device uses palettes}
  IsDestPaletteDevice: bool; {if the device uses palettes}
  BitmapInfoSize: integer; {sizeof the bitmapinfoheader}
  lpBitmapInfo: PBitmapInfo; {the bitmap info header}
  hBm: hBitmap; {handle to the bitmap}
  hPal: hPalette; {handle to the palette}
  OldPal: hPalette; {temp palette}
  hBits: THandle; {handle to the DIB bits}
  pBits: pointer; {pointer to the DIB bits}
  lPPalEntriesArray: PPalEntriesArray; {palette entry array}
  NumPalEntries: integer; {number of palette entries}
  i: integer; {looping variable}
begin
  {If range checking is on - lets turn it off for now}
  {we will remember if range checking was on by defining}
  {a define called CKRANGE if range checking is on.}
  {We do this to access array members past the arrays}
  {defined index range without causing a range check}
  {error at runtime. To satisfy the compiler, we must}
  {also access the indexes with a variable. ie: if we}
  {have an array defined as a: array[0..0] of byte,}
  {and an integer i, we can now access a[3] by setting}
  {i := 3; and then accessing a[i] without error}
{$IFOPT R+}
{$DEFINE CKRANGE}
{$R-}
{$ENDIF}

  {Save the original width of the bitmap}
  OriginalWidth := bm.Width;

  {Get the screen's dc to use since memory dc's are not reliable}
  dc := GetDc(0);
  {Are we a palette device?}
  IsPaletteDevice :=
    GetDeviceCaps(dc, RASTERCAPS) and RC_PALETTE = RC_PALETTE;
  {Give back the screen dc}
  dc := ReleaseDc(0, dc);

  {Allocate the BitmapInfo structure}
  if IsPaletteDevice then
    BitmapInfoSize := sizeof(TBitmapInfo) + (sizeof(TRGBQUAD) * 255)
  else
    BitmapInfoSize := sizeof(TBitmapInfo);
  GetMem(lpBitmapInfo, BitmapInfoSize);

  {Zero out the BitmapInfo structure}
  FillChar(lpBitmapInfo^, BitmapInfoSize, #0);

  {Fill in the BitmapInfo structure}
  lpBitmapInfo^.bmiHeader.biSize := sizeof(TBitmapInfoHeader);
  lpBitmapInfo^.bmiHeader.biWidth := OriginalWidth;
  lpBitmapInfo^.bmiHeader.biHeight := bm.Height;
  lpBitmapInfo^.bmiHeader.biPlanes := 1;
  if IsPaletteDevice then
    lpBitmapInfo^.bmiHeader.biBitCount := 8
  else
    lpBitmapInfo^.bmiHeader.biBitCount := 24;
  lpBitmapInfo^.bmiHeader.biCompression := BI_RGB;
  lpBitmapInfo^.bmiHeader.biSizeImage :=
    ((lpBitmapInfo^.bmiHeader.biWidth *
    longint(lpBitmapInfo^.bmiHeader.biBitCount)) div 8) *
    lpBitmapInfo^.bmiHeader.biHeight;
  lpBitmapInfo^.bmiHeader.biXPelsPerMeter := 0;
  lpBitmapInfo^.bmiHeader.biYPelsPerMeter := 0;
  if IsPaletteDevice then
  begin
    lpBitmapInfo^.bmiHeader.biClrUsed := 256;
    lpBitmapInfo^.bmiHeader.biClrImportant := 256;
  end
  else
  begin
    lpBitmapInfo^.bmiHeader.biClrUsed := 0;
    lpBitmapInfo^.bmiHeader.biClrImportant := 0;
  end;

  {Take ownership of the bitmap handle and palette}
  hBm := bm.ReleaseHandle;
  hPal := bm.ReleasePalette;

  {Get the screen's dc to use since memory dc's are not reliable}
  dc := GetDc(0);

  if IsPaletteDevice then
  begin
    {If we are using a palette, it must be}
    {selected into the dc during the conversion}
    OldPal := SelectPalette(dc, hPal, TRUE);
    {Realize the palette}
    RealizePalette(dc);
  end;
  {Tell GetDiBits to fill in the rest of the bitmap info structure}
  GetDiBits(dc,
    hBm,
    0,
    lpBitmapInfo^.bmiHeader.biHeight,
    nil,
    TBitmapInfo(lpBitmapInfo^),
    DIB_RGB_COLORS);

  {Allocate memory for the Bits}
  hBits := GlobalAlloc(GMEM_MOVEABLE,
    lpBitmapInfo^.bmiHeader.biSizeImage);
  pBits := GlobalLock(hBits);
  {Get the bits}
  GetDiBits(dc,
    hBm,
    0,
    lpBitmapInfo^.bmiHeader.biHeight,
    pBits,
    TBitmapInfo(lpBitmapInfo^),
    DIB_RGB_COLORS);

  if IsPaletteDevice then
  begin
    {Lets fix up the color table for buggy video drivers}
    GetMem(lPPalEntriesArray, sizeof(TPaletteEntry) * 256);
{$IFDEF VER100}
    NumPalEntries := GetPaletteEntries(hPal,
      0,
      256,
      lPPalEntriesArray^);
{$ELSE}
    NumPalEntries := GetSystemPaletteEntries(dc,
      0,
      256,
      lPPalEntriesArray^);
{$ENDIF}
    for i := 0 to (NumPalEntries - 1) do
    begin
      lpBitmapInfo^.bmiColors[i].rgbRed :=
        lPPalEntriesArray^[i].peRed;
      lpBitmapInfo^.bmiColors[i].rgbGreen :=
        lPPalEntriesArray^[i].peGreen;
      lpBitmapInfo^.bmiColors[i].rgbBlue :=
        lPPalEntriesArray^[i].peBlue;
    end;
    FreeMem(lPPalEntriesArray, sizeof(TPaletteEntry) * 256);
  end;

  if IsPaletteDevice then
  begin
    {Select the old palette back in}
    SelectPalette(dc, OldPal, TRUE);
    {Realize the old palette}
    RealizePalette(dc);
  end;

  {Give back the screen dc}
  dc := ReleaseDc(0, dc);

  {Is the Dest dc a palette device?}
  IsDestPaletteDevice :=
    GetDeviceCaps(DestDc, RASTERCAPS) and RC_PALETTE = RC_PALETTE;

  if IsPaletteDevice then
  begin
    {If we are using a palette, it must be}
    {selected into the dc during the conversion}
    OldPal := SelectPalette(DestDc, hPal, TRUE);
    {Realize the palette}
    RealizePalette(DestDc);
  end;

  {Do the blt}
  StretchDiBits(DestDc,
    x,
    y,
    Width,
    Height,
    0,
    0,
    OriginalWidth,
    lpBitmapInfo^.bmiHeader.biHeight,
    pBits,
    lpBitmapInfo^,
    DIB_RGB_COLORS,
    SrcCopy);

  if IsDestPaletteDevice then
  begin
    {Select the old palette back in}
    SelectPalette(DestDc, OldPal, TRUE);
    {Realize the old palette}
    RealizePalette(DestDc);
  end;

  {De-Allocate the Dib Bits}
  GlobalUnLock(hBits);
  GlobalFree(hBits);

  {De-Allocate the BitmapInfo}
  FreeMem(lpBitmapInfo, BitmapInfoSize);

  {Set the ownership of the bimap handles back to the bitmap}
  bm.Handle := hBm;
  bm.Palette := hPal;

  {Turn range checking back on if it was on when we started}
{$IFDEF CKRANGE}
{$UNDEF CKRANGE}
{$R+}
{$ENDIF}
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  if PrintDialog1.Execute then
  begin
    Printer.BeginDoc;
    BltTBitmapAsDib(Printer.Canvas.Handle,
      0,
      0,
      Image1.Picture.Bitmap.Width,
      Image1.Picture.Bitmap.Height,
      Image1.Picture.Bitmap);
    Printer.EndDoc;
  end;
end;