procedure FontScaleBy(R: TRichedit; Prozent: Double); 
const 
  a: array[0..2] of byte = (92, 102, 115); 
var 
  msq, msz: TMemorystream; 
  p1, p2: ^byte; 
  x: integer; 
  pt: boolean; 
  procedure next(i: integer); 
  begin 
    inc(x, i); 
    inc(p1, i); 
    inc(p2, i); 
  end; 
  procedure doit; 
  var 
    c: char; 
    s: string; 
  begin 
    s := ''; 
    next(3); 
    msz.CopyFrom(msq, x - msq.Position); 
    repeat 
      msq.ReadBuffer(c, 1); 
      next(1); 
      if not (c in ['0'..'9']) then 
        break; 
      s := s + c; 
    until false; 
    if s <> '' then 
    begin 
      s := IntToStr(round((strtoint(s) * prozent) / 100)); 
      msz.WriteBuffer(s[1], length(s)); 
    end; 
    msz.WriteBuffer(c, 1); 
  end; 
begin 
  R.Lines.BeginUpdate; 
  prozent := Abs(prozent); 
  pt := R.PlainText; 
  R.PlainText := false; 
  msq := TMemorystream.create; 
  msz := TMemorystream.create; 
  R.Lines.SaveToStream(msq); 
  msq.Position := 0; 
  p1 := msq.Memory; 
  p2 := msq.Memory; 
  inc(p1); 
  x := 1; 
  while x < msq.Size - 4 do 
  begin 
    if CompareMem(@a, p1, 3) and (p2^ <> a[0]) then 
      doit 
    else 
      next(1); 
  end; 
  msz.CopyFrom(msq, msq.Size - msq.Position); 
  msz.Position := 0; 
  R.Lines.LoadFromStream(msz); 
  msz.Free; 
  msq.Free; 
  R.PlainText := pt; 
  R.Lines.endupdate; 
end; 
 
// Beispielaufruf: 
// Die Schriften werden auf 115% der aktuellen Größe erhöht 
procedure TForm1.Button1Click(Sender: TObject); 
begin 
  FontScaleBy(RichEdit1, 115); 
end;

function FontChange(RE: TRichEdit; Prozent: Single; uGrenze: Byte = 10; 
  oGrenze: Word = 100): Integer; 
const 
  beg = '\rtf1\ansi\'; 
  ts = '\fs'; 
var 
  ss: TStringStream; 
  s, such, merk: String; 
  start, v, h: Integer; 
  i: Word; 
  pt: Boolean; 
begin 
  if (Prozent = 0.0) or (RE.Text = '') then 
  begin 
    Result := 1; 
    exit; 
  end; 
  Result := 0; 
  pt := RE.PlainText; 
  RE.PlainText := false; 
  ss := TStringStream.Create; 
  RE.Lines.SaveToStream(ss); 
  s := ss.DataString; 
  ss.Free; 
  merk := s; 
  such := Copy(s, 2, 11); 
  if such = beg then 
  begin 
    start := 13; 
    v := ansipos('{', Copy(s, start, maxint)); 
    if v = 0 then 
    begin 
      Result := 1; 
      exit; 
    end; 
    start := start + v; 
    repeat 
      v := pos(ts, Copy(s, start, maxint)); 
      if v = 0 then 
        break; 
      inc(start, v); 
      h := pos(#32, Copy(s, start, maxint)); 
      such := Copy(s, start + 2, h - 3); 
      try 
        i := Round(StrToInt(such) * Prozent / 100); 
        if (i < uGrenze) and (Prozent < 100) then 
        begin 
          Result := 1; 
          s := merk; 
        end 
        else if (i > oGrenze) and (Prozent > 100) then 
        begin 
          Result := 2; 
          such := IntToStr(oGrenze); 
        end 
        else 
          such := IntToStr(i); 
        if Result <> 1 then 
          s := Copy(s, 1, start + 1) + such + Copy(s, pred(start) + h, maxint); 
        inc(start, h); 
      except 
        Result := 3; 
      end; 
    until false; 
    if Result < 2 then 
    begin 
      ss := TStringStream.Create(s); 
      RE.Lines.LoadFromStream(ss); 
      ss.Free; 
    end; 
    RE.PlainText := pt; 
  end; 
end; 
 

// Beispiel 2 (um 10% vergrößern) 

procedure TForm8.Button4Click(Sender: TObject); 
var 
  s: String; 
  maxgross: Word; 
  Prozent: Single; 
begin 
  maxgross := 300; 
  Prozent := 110; 
  case FontChange(RichEdit1, Prozent, 0, maxgross) of 
    0: 
      s := 'O.K.'; 
    1: 
      s := 'Nichts zur Bearbeitung gefunden'; 
    2: 
      s := 'Größe-Grenze überschritten'; 
  else 
    s := 'Fehler'; 
  end; 
  showmessage(s); 
end; 
 

// Beispiel 2  (um 10% verkleinern) 

procedure TForm8.Button5Click(Sender: TObject); 
begin 
  FontChange(RichEdit1, 90); 
end;

function FontChange(Re: TRichEdit; Prozent: single; uGrenze: Byte = 10) 
  : Integer; 
const 
  beg = '\rtf1\ansi\'; 
  nbeg = '\rtf1\fbidis\ansi\'; 
  ts = '\fs'; 
var 
  ss: TStringStream; 
  hlp, s, such, merk: String; 
  start, v, h, h2: Integer; 
  i: Word; 
  pt, zw: Boolean; 
begin 
  if (Prozent = 0.0) or (Re.Text = '') then 
  begin 
    Result := 1; 
    exit; 
  end; 
  Result := 0; 
  pt := Re.PlainText; 
  Re.PlainText := false; 
  ss := TStringStream.Create; 
  Re.Lines.SaveToStream(ss); 
  s := ss.DataString; 
  ss.Free; 
  merk := s; 
  such := Copy(s, 2, 11); 
  start := 13; 
  zw := such = beg; 
  if not zw then 
  begin 
    such := Copy(s, 2, 18); 
    start := 20; 
    zw := such = nbeg; 
  end; 
  if zw then 
  begin 
    h := pos('{', Copy(s, start, maxint)); 
    if h = 0 then 
    begin 
      Result := 1; 
      exit; 
    end; 
    repeat 
      v := pos(ts, Copy(s, start, maxint)); 
      if v = 0 then 
        break; 
      inc(v, 2); 
      hlp := Copy(s, v + start, maxint); 
      h := pos(#32, Copy(hlp, 1, maxint)); 
      if h = 0 then 
        break; 
      h2 := pos('\', Copy(hlp, 1, maxint)); 
      if h2 < h then 
      begin 
        inc(start, h2); 
        continue; 
      end; 
      such := Copy(hlp, 1, h - 1); 
      try 
        i := Round(StrToInt(such) * Prozent / 100); 
        if i < uGrenze then 
        begin 
          Result := 2; 
          break; 
        end; 
        such := IntToStr(i); 
        hlp := Copy(s, 1, start + v - 1) + such + #32; 
        s := hlp + Copy(s, start + v + 3, maxint); 
        start := length(hlp); 
      except 
        Result := 3; 
      end; 
    until false; 
    if Result = 0 then 
      ss := TStringStream.Create(s) 
    else 
      ss := TStringStream.Create(merk); 
    Re.Lines.LoadFromStream(ss); 
    ss.Free; 
    Re.PlainText := pt; 
  end; 
end;

procedure REZoom(RE: TRichEdit; Zoom: Integer); 
begin 
  if Zoom = 0 then 
    SendMessage(RE.Handle, EM_SETZOOM, 0, 0) 
  else 
    SendMessage(RE.Handle, EM_SETZOOM, Zoom, 100); 
end; 
 
// größer 
procedure TForm1.Button4Click(Sender: TObject); 
begin 
  REZoom(RichEdit1, 133); 
end; 
 
// 100% 
procedure TForm1.Button5Click(Sender: TObject); 
begin 
  REZoom(RichEdit1, 0); 
end;