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');

ifnot 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 = 128then

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 := 1to Length(s) do

if s[i] = #9then

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)] = #32then

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) > 0then

begin

if s1[Length(s1)] = #9then

delete(s1, Length(s1), 1);

if s1[length(s1) - 1] + s1[length(s1)] = #13#10then

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 := 1to 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 := 1to Length(line.s) do

if line.s[j] = #32then

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 := 1to 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 = #9then

begin

inc(TextLeft, 40);

end

else

begin

if OneWord = #13#10then

begin

inc(LineN);

end

else

begin

TextOut(10 + TextLeft, LineN * LineH, OneWord);

if SpaceCount = 0then

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;