Begræns tekst længden til printer

Der er vel ingen anden vej end at bruge Canvas.TextWidth(st) eller Canvas.TextExtent(st) til at vurdere om der er plads, er der? Hvis andre har bedre ideer vil jeg også gerne vide det ;-)

Noget med at loope en streng igennem bagfra indtil at den kan være på den plads der er beregnet:

procedure TfrmMain.Button1Click(Sender: TObject);
var
  st : string;
  Row, i : integer;
begin
  st := InputBox('Indtast en streng','Her:',st);
  Row := 0;
  while st <> '' do begin
    i := length(st);
    while (i > 0) and (Canvas.TextWidth(st[i]) > PixelsAvaliable) do
      dec(i);

    if i > 0 then begin
      Canvas.TextOut(0,Row,copy(st,1,i);
      delete(st,1,i);
    end;
    inc(Row);
  end; // while
end;

(ikke testet!)

Nå ja, burde have testet det. Her kommer en anden version:

procedure TfrmMain.Button1Click(Sender: TObject);
var
  st : string;
  Row, i : integer;
  PixelsAvaliable : integer;
  RowHeight : integer;
begin
  PixelsAvaliable := ClientWidth;
  RowHeight := Canvas.TextHeight('X') + 2;

  st := InputBox('Indtast en streng','Her:',st);
  Row := 0;
  while st <> '' do begin
    i := length(st);
    while (i > 0) and (Canvas.TextWidth(copy(st,1,i)) > PixelsAvaliable) do
      dec(i);

    if i > 0 then begin
      Canvas.TextOut(0,Row,copy(st,1,i));
      delete(st,1,i);
    end;
    inc(Row,RowHeight);
  end; // while
end;

Hvis man bruger
  with printer do
kan det lade sig gøre

procedure TForm1.over1Change(Sender: TObject);
var
  laengde, Sidebredde: integer;
begin
  Sidebredde := CmX(PapirBredde-margin);
  with printer do
  begin
    canvas.font.size := 100;
    canvas.font.name := 'Balloon Lt BT';
    laengde := canvas.Textwidth(over1.text);
  if (sidebredde < laengde) then
    begin
      ShowMessage('Teksten "' + over1.Text + '" er for lang - Slet sidste tegn.' );
    end;
  end;
end;

ht-delphi: Du bruger også TextWidth men jeg så ingen grund til ikke at modificere løsningen således at den bare fortsatte på næste linie. En yderligere forbedring er at finde den maksimale strenglængde og så søge endnu videre tilbare indtil man når et mellemrum eller bindestreg.

Har tit undret mig over de ret primitive udskrivningsfunktioner, men sådanne er jo ret lette pakke ind i noget objektorienteret - og så er det kun bekvemt at de er så simple.

Min "find-maksimale-streng" rutine er skrækkelig tung og måske skulle man ændre den til noget med binær, eller grov-beregne det som nedenfor (man har jo strengens og sidens bredde):

    i := trunc(length(st) * (PixelsAvaliable / Canvas.TextWidth(st)));

Faktisk kan den erstatte:

    i := length(st);
    while (i > 0) and (Canvas.TextWidth(copy(st,1,i)) > PixelsAvaliable) do
      dec(i);

Harald kender til Printers-unitten og kan sikkert se at det er meget simpelt at flytte eksemplet over på printeren (gad bare ikke bruge papir på at teste) - nedenstående "Full Scale" og afsluttende eksempel resulterede i ca. 50 sider med "the quick brown fox jumps over the lazy dogs æøå" på firmaets centrale printer ... ahem...

type // fMargins er defineret i formen frmMain's private sektion
  TMargins = record
    Top, Bottom, Left, Right : double;
  end;

procedure TfrmMain.FormCreate(Sender: TObject);
begin
  fMargins.Top := 1; // I tommer
  fMargins.Bottom := 1;
  fMargins.Left := 1;
  fMargins.Right := 1;
end;

procedure TfrmMain.Button2Click(Sender: TObject);
var
  st : string;
  Row, i : integer;
  RowHeight : integer;
  PixelsPrTomme : integer;
  TopMarginStart, LeftMarginStart : integer;
  WorkWidth, WorkHeight : integer;
  TopMarginStart, LeftMarginStart : integer;
begin
  st := trim(Edit1.Text);

  with Printer do begin
    BeginDoc;
    try
      Canvas.Font.Size := 100;
      Canvas.Font.Name := 'Balloon Lt BT';

      PixelsPrTomme := GetDeviceCaps(Printer.Handle, LOGPIXELSX);
      RowHeight := Canvas.TextHeight('X') + 2;

      WorkWidth := trunc(PageWidth - (fMargins.Left + fMargins.Right) * PixelsPrTomme);
      WorkHeight := trunc(PageHeight - (fMargins.Top + fMargins.Bottom) * PixelsPrTomme);

      TopMarginStart := trunc(fMargins.Top * PixelsPrTomme);
      LeftMarginStart := trunc(fMargins.Left * PixelsPrTomme);

      Row := TopMarginStart;
      while st <> '' do begin
        i := trunc(length(st) * (WorkWidth / Canvas.TextWidth(st)));
        if i > 0 then begin
          Canvas.TextOut(LeftMarginStart,Row,copy(st,1,i));
          delete(st,1,i);
        end;

        inc(Row,RowHeight);
        if Row > WorkHeight then begin
          NewPage;
          Row := TopMarginStart;
        end; // if
      end; // while
    finally
      EndDoc;
    end; // try
  end; // with
end;

Naturligvis fandt jeg en fejl:

      PixelsPrTomme := GetDeviceCaps(Printer.Handle, LOGPIXELSX);

gælder naturligvis kun for X-aksen...

procedure TfrmMain.Button2Click(Sender: TObject);
var
  st : string;
  Row, i : integer;
  RowHeight : integer;
  WorkWidth, WorkHeight : integer;
  XPixelsPrTomme, YPixelsPrTomme : integer;
  TopMarginStart, LeftMarginStart : integer;
begin
  st := trim(Edit1.Text);

  with Printer do begin
    BeginDoc;
    try
      Canvas.Font.Size := 100;
      Canvas.Font.Name := 'Balloon Lt BT';

      XPixelsPrTomme := GetDeviceCaps(Printer.Handle, LOGPIXELSX);
      YPixelsPrTomme := GetDeviceCaps(Printer.Handle, LOGPIXELSY);

      RowHeight := Canvas.TextHeight('X') + 2;

      WorkWidth := trunc(PageWidth - (fMargins.Left + fMargins.Right) * XPixelsPrTomme);
      WorkHeight := trunc(PageHeight - (fMargins.Top + fMargins.Bottom) * YPixelsPrTomme);

      TopMarginStart := trunc(fMargins.Top * XPixelsPrTomme);
      LeftMarginStart := trunc(fMargins.Left * YPixelsPrTomme);

      Row := TopMarginStart;
      while st <> '' do begin
        i := trunc(length(st) * (WorkWidth / Canvas.TextWidth(st)));
        if i > 0 then begin
          Canvas.TextOut(LeftMarginStart,Row,copy(st,1,i));
          delete(st,1,i);
        end;

        inc(Row,RowHeight);
        if Row > WorkHeight then begin
          NewPage;
          Row := TopMarginStart;
        end; // if
      end; // while
    finally
      EndDoc;
    end; // try
  end; // with
end;

ht-delphi: Kan du bruge noget af det jeg har lavet eller venter du på at andre skal melde ind???