Выравнивание текста по ширине

Материал из DRKB

Выравнивание текста по ширине[править | править код]

Текст выглядит лучше, если он выровнен по двух краям. Для этого пробелы в каждой строке нужно удлинять или укорачивать так, чтобы все строки имели одну длину.

Image 2021-02-12 012524.png


Здесь создана процедура GetLine, которая возвращает одну строку, начиная с заданного символа. Программа находит разницу между шириной текста и реальной длинной строки и при выводе компенсирует эту разницу удлинением пробелов.

Эта программа выводит на экран текст из файла C:\text.txt, выравнивая его по двум краям.

type
  TLineItem = record
    s: string;
    Wrap: Boolean;
    Length: Integer;
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

const
  FileName = 'C:\text.txt';

var
  s: string;
  bm: TBitMap;
  LineH: Integer;
  MaxTextWidth: Integer;

procedure TForm1.FormCreate(Sender: TObject);
var
  F: TFileStream;
  buf: array [0..127] of Char;
  l: Integer;
begin
  ScrollBar1.Kind := sbVertical;
  bm := TBitMap.Create;
  with bm.Canvas.Font do
  begin
    Name := 'Serif';
    Size := 12;
  end;
  LineH := bm.Canvas.TextHeight('123');

  if not FileExists(FileName) then
  begin
    ShowMessage('Can not find file ' + FileName);
    Exit;
  end;
  F := TFileStream.Create(FileName, fmOpenRead);
  repeat
    l := F.Read(buf, 128);
    if l = 128 then
      s := s + buf
    else
      s := s + Copy(buf, 1, l);
  until
    l < 128;
  F.Destroy;
end;

procedure TForm1.FormResize(Sender: TObject);
begin
  PaintBox1.Left := 0;
  PaintBox1.Top := 0;
  PaintBox1.Height := Form1.ClientHeight;
  PaintBox1.Width := Form1.ClientWidth - ScrollBar1.Width;
  ScrollBar1.Left := PaintBox1.Width;
  ScrollBar1.Top := 0;
  ScrollBar1.Height := PaintBox1.Height;
  bm.Width := PaintBox1.Width;
  bm.Height := PaintBox1.Height;
  ScrollBar1.Max := 1000;
  MaxTextWidth := PaintBox1.Width - 20;
end;

function RealTextWidth(s: string): Integer;
var
  i: Integer;
begin
  Result := bm.Canvas.TextWidth(s);
  for i := 1 to Length(s) do
    if s[i] = #9 then
      Inc(Result, 40 - bm.Canvas.TextWidth(#9));
end;

function GetLineItem(index: Integer): TLineItem;
var
  i: Integer;
  s1: string;
  first: Integer;
begin
  if s = '' then Exit;
  if (s[index] = #13) and (s[index + 1] = #10) then
  begin
    Result.s := '';
    Result.Length := 2;
    Result.Wrap := True;
    Exit;
  end;
  first := index;
  while (first <= Length(s)) and (s[first] in [#32]) do
    Inc(first);
  i := first;
  repeat
    while (i <= Length(s)) and (not (s[i] in [#9, #32])) and (s[i] <> #13) do
      Inc(i);
    s1 := Copy(s, first, i - index);
    Inc(i);
  until
    (i >= Length(s)) or (s[i-1] = #13) or (RealTextWidth(s1) > MaxTextWidth);
  if RealTextWidth(s1) > MaxTextWidth then
  begin
    Result.Wrap := False;
    if i < Length(s) then
    begin
      Dec(i, 2);
      while (i > 0) and (not (s[i] in [#9, #32])) do
        Dec(i);
      Result.Length := i - index;
      while (i > 0) and (s[i] in [#9, #32]) do
        Dec(i);
    end;
    Result.s := Copy(s, first, i - index + 1);
    if Result.s[Length(Result.s)] = #32 then
      Delete(Result.s, Length(Result.s), 1);
  end
  else
  begin
    Result.Length := i - index + 1;
    s1 := Copy(s, first, i - index + 1);
    if Length(s1) > 0 then
    begin
      if s1[Length(s1)] = #9 then
        Delete(s1, Length(s1), 1);
      if s1[length(s1) - 1] + s1[length(s1)] = #13#10 then
        Delete(s1, Length(s1) - 1, 2);
    end;
    Result.s := s1;
    Result.Wrap := True;
  end;
end;

procedure Draw();
var
  i, j: Integer;
  LineItem: TLineItem;
  OneWord: string;
  LineN: Integer;
  SpaceCount: Integer;
  TextLeft: Integer;
  shift, AllShift: Integer;
  d: Integer;
  LineCount: Integer;
begin
  if s = '' then Exit;
  OneWord := '';
  with bm.Canvas do
  begin
    FillRect(ClipRect);
    i := 1;
    LineCount := 0;
    for j := 1 to Form1.ScrollBar1.Position do
    begin
      LineItem := GetLineItem(i);
      Inc(i, LineItem.Length);
      Inc(LineCount);
    end;
    LineN := 0;
    repeat
      LineItem := GetLineItem(i);
      SpaceCount := 0;
      TextLeft := 0;
      for j := 1 to Length(LineItem.s) do
        if LineItem.s[j] = #32 then
          Inc(SpaceCount);
      if LineItem.Wrap = False then
        AllShift := MaxTextWidth - RealTextWidth(LineItem.s)
      else
        AllShift := 0;
      if AllShift > 40 * SpaceCount then
        AllShift := 0;
      shift := 0;
      for j := 1 to Length(LineItem.s) do
      begin
        if (not (LineItem.s[j] in [#9, #32])) and (j < Length(LineItem.s)) then
        begin
          OneWord := OneWord + LineItem.s[j];
        end
        else
        begin
          OneWord := OneWord + LineItem.s[j];
          if OneWord = #9 then
          begin
            Inc(TextLeft, 40);
          end
          else
          begin
            if OneWord = #13#10 then
            begin
              Inc(LineN);
            end
            else
            begin
              TextOut(10 + TextLeft, LineN * LineH, OneWord);
              if SpaceCount = 0 then
                d := 0
              else
                d := (AllShift - shift) div (SpaceCount);
              Inc(shift, d);
              Inc(TextLeft, TextWidth(OneWord) + d);
              Dec(SpaceCount);
            end;
          end;
          OneWord := '';
        end;
      end;
      Inc(i, LineItem.Length);
      Inc(LineN);
    until
      (LineN * LineH > Form1.PaintBox1.Height) or (i >= Length(s));

    repeat
      LineItem := GetLineItem(i);
      Inc(i, LineItem.Length);
      Inc(LineCount);
    until
      i >= Length(s);

    Inc(LineCount, LineN);
    if LineCount - Form1.PaintBox1.Height div LineH > 0 then
      Form1.ScrollBar1.Max := LineCount - Form1.PaintBox1.Height div LineH;
  end;
  Form1.PaintBox1.Canvas.Draw(0, 0, bm);
end;

procedure TForm1.PaintBox1Paint(Sender: TObject);
begin
  Draw;
end;

procedure TForm1.ScrollBar1Change(Sender: TObject);
begin
  Draw;
end;


Source: http://delphiworld.narod.ru/
ID: 00843
ID: 03655