// Mit dem folgenden Code kann man (unterschiedlich großen) Text in einem
//
TRichEdit nach Belieben vergrößern oder verkleinern (skalieren).
// Voraussetzung sind Schriften, die in allen Schriftgrößen darstellbar
// sind
(TrueType). Andere Schriften werden nur begrenzt unterstützt.
// Die Variable "Prozent" bestimmt dabei die Skalierung. Hat sie
// beispielsweise den Wert 50, werden alle Buchstaben jeweils auf die Hälfte
// verkleinert. Hat sie den Wert 200, werden die Buchstaben in doppelter
// Größe dargestellt; immer im Bezug auf die gerade aktuelle Schriftgröße.

// Getestet mit D4 unter XP

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;



Zugriffe seit 6.9.2001 auf Delphi-Ecke