DBR Delphi-Ecke

// Hiermit werden Grafiken millimetergenau ausgedruckt. Es wird die
// gewünschte Bildbreite (Bildhöhe) angegeben, die Bildhöhe (Bildbreite)
// wird automatisch berechnet. Siehe auch TStrings millimetergenau drucken

// Getestet mit D4 unter Win98

uses Printers; 
 
procedure Grafik_mm_Druck(Grafik: TGraphic; Mass: double;
  MassIstErwarteteBreite: boolean; links, oben: integer); 
var 
  h: THandle; 
  waagerechtePixel, senkrechtePixel: integer; 
  BildHoehe, BildBreite: double; 
  r: TRect; 
  function rechnen(a: integer; w: double): integer; 
  begin 
    result := round((a * w) / 25.4); 
  end; 
begin 
  h := printer.handle; 
  if MassIstErwarteteBreite then begin 
    BildHoehe := Mass * (grafik.height / grafik.width); 
    BildBreite := Mass; 
  end else begin 
    BildBreite := Mass * (grafik.width / grafik.height); 
    BildHoehe := Mass; 
  end; 
  waagerechtePixel := getdevicecaps(h, logpixelsx); 
  senkrechtePixel := getdevicecaps(h, logpixelsy); 
  links := rechnen(waagerechtePixel, links) - getdevicecaps(h, physicaloffsetx); 
  oben := rechnen(senkrechtePixel, oben) - getdevicecaps(h, physicaloffsety); 
  r := rect(links, oben, links + rechnen(waagerechtePixel, BildBreite), 
    oben + rechnen(senkrechtePixel, BildHoehe)); 
  with printer do begin 
    begindoc; 
    canvas.stretchdraw(r, Grafik); 
    enddoc; 
  end; 
end; 
 
// die Werte für die gewünschte Bildbreite (33,true), den Abstand von der 
// linken Blattkante (50) und den Abstand von der oberen Blattkante (25) 
// werden in Millimetern angegeben 
 
procedure TForm1.Button2Click(Sender: TObject); 
begin 
  Grafik_mm_Druck(Image1.picture.graphic, 33, True, 50, 25); 
end; 
 
// der erste Wert ist diesmal die erwartete Bildhöhe (33,false) 
 
procedure TForm1.Button3Click(Sender: TObject); 
begin 
  Grafik_mm_Druck(Image1.picture.graphic, 33, False, 50, 25); 
end;

//---------------------------------------------------------------

// Wenn mehrere Bilder auf ein und dem selben Blatt gedruckt werden müssen,
// ermittelt man zunächst Größe und Stelle der Rechtecke, in denen sie
// abgebildet werden sollen, und druckt dann erst aus.

uses Printers; 
 
var 
  gr: array of TGraphic; 
  tr: array of TRect; 
  zweiterWert: integer; 
 
procedure druck(grfk: array of TGraphic; rr: array of TRect); 
var x: integer; 
begin 
  with printer do begin 
    begindoc; 
    for x := 0 to length(grfk) - 1 do 
      canvas.stretchdraw(rr[x], grfk[x]); 
    enddoc; 
  end; 
end; 
 
function Grafik_mm_Vorbereitung(Grafik: TGraphic; Mass: double; 
  MassIstErwarteteBreite: boolean; links, oben: integer): TRect; 
var 
  h: THandle; 
  waagerechtePixel, senkrechtePixel: integer; 
  BildHoehe, BildBreite: double; 
  function rechnen(a: integer; w: double): integer; 
  begin 
    result := round((a * w) / 25.4); 
  end; 
begin 
  h := printer.handle; 
  if MassIstErwarteteBreite then begin 
    BildHoehe := Mass * (grafik.height / grafik.width); 
    BildBreite := Mass; 
    zweiterWert := round(BildHoehe); 
  end else begin 
    BildBreite := Mass * (grafik.width / grafik.height); 
    BildHoehe := Mass; 
    zweiterWert := round(BildBreite); 
  end; 
  waagerechtePixel := getdevicecaps(h, logpixelsx); 
  senkrechtePixel := getdevicecaps(h, logpixelsy); 
  links := rechnen(waagerechtePixel, links) - getdevicecaps(h, physicaloffsetx); 
  oben := rechnen(senkrechtePixel, oben) - getdevicecaps(h, physicaloffsety); 
  result := rect(links, oben, links + rechnen(waagerechtePixel, BildBreite), 
    oben + rechnen(senkrechtePixel, BildHoehe)); 
end; 
 
// Beispielaufruf 
 
procedure TForm1.Button1Click(Sender: TObject); 
var anzahl: integer; 
begin 
  anzahl := 3; 
  setlength(gr, anzahl); 
  setlength(tr, anzahl); 
  gr[0] := Image1.picture.graphic; 
  gr[1] := Image2.picture.graphic; 
  gr[2] := Image3.picture.graphic; 
  tr[0] := Grafik_mm_Vorbereitung(gr[0], 33, True, 50, 25); 
  tr[1] := Grafik_mm_Vorbereitung(gr[1], 50, True, 50, 100); 
  tr[2] := Grafik_mm_Vorbereitung(gr[2], 45, True, 150, 25); 
  druck(gr, tr); 
  gr := nil; 
  tr := nil; 
end;

// wenn mal will, dass die Bilder direkt aneinander
// gedruckt werden, wie hier rechts zu sehen ist, ------>
// kann man z.B. folgendes machen:

 
procedure TForm1.Button5Click(Sender: TObject); 
var anzahl, breite, merk: integer; 
begin 
  anzahl := 3; 
  breite := 40; 
  setlength(gr, anzahl); 
  setlength(tr, anzahl); 
  gr[0] := Image1.picture.graphic; 
  gr[1] := Image2.picture.graphic; 
  gr[2] := Image3.picture.graphic; 
  tr[0] := Grafik_mm_Vorbereitung(gr[0], breite, True, 50, 25); 
  merk := zweiterWert; 
  tr[1] := Grafik_mm_Vorbereitung(gr[1], breite, True, 50 + breite, 25); 
  tr[2] := Grafik_mm_Vorbereitung(gr[2], breite, True, 50, 25 + merk); 
  druck(gr, tr); 
  gr := nil; 
  tr := nil; 
end;