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;