Modell: Ausgabe von formatiertem Text

[jbg]

Ich habe da so was. Vielleicht kannst du das gut gebrauchen.

Code:

function SubStr(const S: string; StartIndex: Integer; Seperator: Char): string;
var P, F: PChar;
begin
  Result := '';
  if (StartIndex < 1) or (StartIndex > Length(S)) then Exit;
  F := PChar(S) + (StartIndex - 1);
  P := StrScan(F, Seperator);
  if P = nil then Exit;
  SetString(Result, F, P - F);
end;

function IsInTextArray(const S: string; const Args: array of string): Integer;
begin
  for Result := High(Args) downto 0 do
    if CompareText(S, Args[Result]) = 0 then Break;
end;

procedure DrawHlTextEx(Canvas: TCanvas; Rect: TRect; TransparentBkgnd: Boolean;
  const State: TOwnerDrawState; const Text: string; HideSelColor: Boolean;
  LineHeight: Integer; out PlainText: string; out Width, Height: Integer;
  CalcWidth: Boolean);
var
  i: Integer;
  S, A: string;
  OrgRect: TRect;
  TextLayout: TTextLayout;

  function Cmp(S: string): Boolean;
  begin
    Result := AnsiStrLIComp(PChar(Text) + i, PChar(S), Length(S)) = 0;
  end;

  function Cmp1(S: string): Boolean;
  begin
    Result := AnsiStrLIComp(PChar(Text) + i, PChar(S), Length(S)) = 0;
    if Result then Inc(i, Length(S));
  end;

  function CmpL(S: string) : boolean;
  begin
    Result := Cmp(S + '>');
  end;

  function CmpL1(S: string) : boolean;
  begin
    Result := Cmp1(S + '>');
  end;

  procedure Draw(const S: string);
  var y: Integer;
  begin
    if not Assigned(Canvas) then Exit;
    if not CalcWidth then
    begin
      y := Rect.Top;
      if LineHeight > 0 then
      begin
        case TextLayout of
          tlCenter: Inc(y, (LineHeight - Canvas.TextHeight(S)) div 2);
          tlBottom: Inc(y, LineHeight - abs(Canvas.Font.Height) - 2);
        end;
      end;
      Canvas.TextOut(Rect.Left, y, S);
    end;
    Rect.Left :=  Rect.Left + Canvas.TextWidth(S);
  end;

  procedure Style(const Style: TFontStyle; const Include: Boolean);
  begin
    if not Assigned(Canvas) then Exit;
    if Include then Canvas.Font.Style := Canvas.Font.Style + [Style]
     else Canvas.Font.Style := Canvas.Font.Style - [Style];
  end;

var
  OldFont: TFont;
  TextLen: Integer;
begin
  PlainText := '';
  OldFont := nil;
  TextLayout := tlTop;
  if Assigned(Canvas) then
  begin
   // Canvas-Einstellungen sichern
    OldFont := TFont.Create;
    OldFont.Assign(Canvas.Font);
  end;
  try
    if HideSelColor and Assigned(Canvas) then
    begin
      Canvas.Brush.Color := clWindow;
      Canvas.Font.Color := clWindowText;
    end;
    if (Assigned(Canvas)) and (not TransparentBkgnd) then
      Canvas.FillRect(Rect);

    Height := Rect.Top;
    Width := Rect.Left;
    Inc(Rect.Left, 2);
    OrgRect := Rect;
    S := '';
    i := 1;
    TextLen := Length(Text); // schneller als laufend Length() aufzurufen
    while i <= TextLen do
    begin
      if (Text[i] = '<') and
        (CmpL('b') or CmpL('/b') or
         CmpL('i') or CmpL('/i') or
         CmpL('u') or CmpL('/u') or
         Cmp('c:') or
         Cmp('fname:') or Cmp('fsize') or
         Cmp('valign:')
        ) then
      begin
        Draw(S);
        PlainText := PlainText + S;

        if CmpL1('b')       then Style(fsBold, True)
        else if CmpL1('/b') then Style(fsBold, False)
        else if CmpL1('i')  then Style(fsItalic, True)
        else if CmpL1('/i') then Style(fsItalic, False)
        else if CmpL1('s')  then Style(fsStrikeOut, True)
        else if CmpL1('/s') then Style(fsStrikeOut, False)
        else if CmpL1('u')  then Style(fsUnderline, True)
        else if CmpL1('/u') then Style(fsUnderline, False)
        else if Cmp1('c:') then // color
        begin
          A := SubStr(Text, i + 1, '>');
          if (HideSelColor or not (odSelected in State)) and Assigned(Canvas) then
          try
            if (Length(A) > 0) and (A[1] <> '$') then
              Canvas.Font.Color := StringToColor('cl' + A)
            else
              Canvas.Font.Color := StringToColor(A);
          except
          end;
          inc(i, Length(A) + 1); {'>' überpringen}
        end else if Cmp1('fname:') then
        begin
          A := SubStr(Text, i + 1, '>');
          if (A = '') and (Assigned(OldFont)) then A := OldFont.Name;
          Canvas.Font.Name := A;
          inc(i, Length(A) + 1); {'>' überpringen}
        end else if Cmp1('fsize:') then
        begin
          A := SubStr(Text, i + 1, '>');
          if A <> '' then
          try
            if CompareText(Copy(A, Length(A) - 2, 2), 'px') = 0 then
              Canvas.Font.Height := StrToInt(Copy(A, 1, Length(A) - 2))
            else
              Canvas.Font.Size := StrToInt(A);
          except
          end;
          inc(i, Length(A) + 1); {'>' überpringen}
        end else if Cmp1('valign:') then
        begin
          A := SubStr(Text, i + 1, '>');
          if A <> '' then
            case IsInTextArray(A, ['Top', 'Center', 'Bottom']) of
              0: TextLayout := tlTop;
              1: TextLayout := tlCenter;
              2: TextLayout := tlBottom;
            end;
          inc(i, Length(A) + 1); {'>' überpringen}
        end;
        S := '';
      end else
      begin
        // neue Zeile (könne auch mit 
 gemacht werden)
        if (Text[i] = #13) and (Cmp1(#10)) then
        begin
          Draw(S);
          PlainText := PlainText + S;
          if Assigned(Canvas) then
          begin
            Rect.Left := OrgRect.Left;
            Inc(Rect.Top, Canvas.TextHeight(S));
          end;
          S := '';
        end else S := S + Text[i]; // Text Zeichen für Zeichen zusammensetzen
      end;
      inc(i);
    end; // for
    Draw(S); // Rest zeichnen
    PlainText := PlainText + S;
  finally
    if Assigned(Canvas) then
    begin
     // Canvas wiederherstellen
      Canvas.Font.Assign(OldFont);
      OldFont.Free;
    end;
  end;
  Width := Rect.Left - Width + 2;
  Height := Rect.Top - Height + 2;
end;

function DrawHlText(Canvas: TCanvas; Rect: TRect; const State: TOwnerDrawState;
  const Text: string; HideSelColor: Boolean; LineHeight: Integer = 0): string;
var
  S: string;
  w, h: Integer;
begin
  DrawHlTextEx(Canvas, Rect, True, State, Text, HideSelColor, LineHeight, S, w, h, False);
end;

function GetHlPlainText(const Text: string): string;
var w, h: Integer;
begin
  DrawHlTextEx(nil, Rect(0, 0, -1, -1), False, [], Text, False, 0, Result, w, h, False);
end;

function GetHlTextExt(Canvas: TCanvas; Rect: TRect; const State: TOwnerDrawState;
  const Text: string; HideSelColor: Boolean): TSize;
var S: string;
begin
  DrawHlTextEx(Canvas, Rect, False, State, Text, HideSelColor, 0, S, Result.cx, Result.cy, True);
end;

procedure TForm1.PaintBox1Paint(Sender: TObject);
begin
  DrawHlText(PaintBox1.Canvas, PaintBox1.ClientRect, [],
    '<c:blue>H<fsize:10>a<fsize:11>l<fsize:12>l<fsize:13>o<fsize:6px><c:black> [b]du da[/b]', False);
end;

Wenn du den ganzen Textblock zentriert ausgeben willst, dann ermittelst du zuerst mit GetHlTextExt die Ausmaße und kannst dann mit diesen zentrieren:

Code:

size := GetHlTextExt(PaintBox1.Canvas, PaintBox1.ClientRect, [], Text, False);
r := PaintBox1.ClientRect;
r.Left := (PaintBox1.Width - size.cx) div 2;
DrawHlText(PaintBox1.Canvas, r, [], Text, False);