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;