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. := 0;

 PaintBox1.Height := Form1.ClientHeight;

 PaintBox1.Width := Form1.ClientWidth - ScrollBar1.Width;

 ScrollBar1.Left := PaintBox1.Width;

 ScrollBar1. := 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;