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

Previous  Top  Next

    
 

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

 

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

 

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

 

Code:

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;

 

 

 

©Drkb::00843

http://delphiworld.narod.ru/

DelphiWorld 6.0