uses printers; 
 
type 
  perc = 10..200; 
 
function Druck(bild: TBitmap; links, oben: integer; 
  prozent: perc; txt: string): boolean; 
var 
  DIBWidth, DIBHeight, logx, logy, bx, by, w, s: integer; 
  InfoSize, ImageSize: DWORD; 
  Info: PBitmapInfo; 
  Image: Pointer; 
  bm: TBitmap; 
  function waag(X: integer): integer; 
  begin 
    result := round((X * LogX) / bX); 
  end; 
  function senk(Y: Integer): integer;
  begin 
    result := round((Y * LogY) / bY);
  end; 
begin
  result := false;
  if (bild.width < 10) or (bild.height < 10) then exit;
  Info := AllocMem(InfoSize);
  Image := AllocMem(ImageSize);
  bm := TBitmap.Create;
  try 
    bm.pixelformat := pf24bit; 
    bm.Width := (bild.Width * prozent) div 100; 
    bm.Height := (bild.Height * prozent) div 100; 
    SetStretchBltMode(bm.canvas.handle, STRETCH_HALFTONE); 
    bm.Canvas.stretchdraw(bm.Canvas.ClipRect, bild); 
    LogX := GetDeviceCaps(Printer.Handle, LOGPIXELSX); 
    LogY := GetDeviceCaps(Printer.Handle, LOGPIXELSY); 
    bX := GetDeviceCaps(bm.Canvas.handle, LOGPIXELSX); 
    bY := GetDeviceCaps(bm.Canvas.handle, LOGPIXELSY); 
    GetDIBSizes(bm.Handle, InfoSize, ImageSize); 
    GetDIB(bm.Handle, 0, Info^, Image^);
    with Info^.bmiHeader do
    begin 
      DIBWidth := biWidth;
      DIBHeight := biHeight;
    end; 
    w := waag(links);
    s := senk(Oben);
    printer.title := txt;
    printer.begindoc;
    StretchDIBits(Printer.Canvas.Handle, 
      w, s, w + waag(bm.width), s + senk(bm.height), 0, 0, 
      DIBWidth, DIBHeight, Image, Info^, DIB_RGB_COLORS, SRCCOPY); 
    printer.enddoc; 
    result := true; 
  finally 
    bm.Free; 
    FreeMem(Image, ImageSize);
    FreeMem(Info, InfoSize);
  end; 
end; 
 
// Beispielaufruf 
procedure TForm1.Button1Click(Sender: TObject); 
begin 
  Button1.Enabled := false; 
  if not druck(Image1.picture.bitmap, 25, 33, 100, 'Bild-Druck') 
    then showmessage('Fehler'); 
  Button1.Enabled := true; 
end;