Sources
Delphi Russian Knowledge Base
DRKB - это самая большая и удобная в использовании база знаний по Дельфи в рунете, составленная Виталием Невзоровым

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

01.01.2007

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

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

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

type
 
...
 
TLine = 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 GetLine(index: integer): TLine;
 
var
  i
: integer;
  s1
: string;
  first
: integer;
begin
 
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;
  line
: TLine;
 
OneWord: string;
 
LineN: integer;
 
SpaceCount: integer;
 
TextLeft: integer;
  shift
, allshift: integer;
  d
: integer;
 
LineCount: integer;
 
begin
 
with bm.Canvas do begin
   
FillRect(ClipRect);
    i
:= 1;
   
LineCount := 0;
   
for j := 1 to Form1.ScrollBar1.Position do begin
      line
:= GetLine(i);
      inc
(i, line.length);
      inc
(LineCount);
   
end;
   
LineN := 0;
    repeat
      line
:= GetLine(i);
     
SpaceCount := 0;
     
TextLeft := 0;
     
for j := 1 to Length(line.s) do
       
if line.s[j] = #32 then inc(SpaceCount);
 
     
if line.wrap = false
       
then allshift := MaxTextWidth - RealTextWidth(line.s)
       
else allshift := 0;
     
if allshift > 40 * SpaceCount then allshift := 0;
      shift
:= 0;
     
for j := 1 to Length(line.s) do begin
       
if (not (line.s[j] in [#9, #32])) and (j < Length(line.s)) then begin
         
OneWord := OneWord + line.s[j];
 
       
end else begin
         
OneWord := OneWord + line.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, line.length);
      inc
(LineN);
   
until (LineN * LineH > Form1.PaintBox1.Height) or (i >= Length(s));
 
    repeat
      line
:= GetLine(i);
      inc
(i, line.length);
      inc
(LineCount);
   
until i >= Length(s);
    inc
(LineCount, LineN);
    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;

Автор: Даниил Карапетян (delphi4all@narod.ru)

Автор справки: Алексей Денисов (aleksey@sch103.krasnoyarsk.su)