Richtige Text länge ist nicht berechenbar

[venice2]

Stehe jetzt selbst auf dem Schlauch.
Ich möchte meinem text ein Ellipsis anhängen '...' wenn diese die weite meines Fensters überschreitet.
Das Problem ist es funktioniert nicht.

Mit den benötigten Funktionen ist es etwas schwerlich zu lesen geht aber leider nicht anders. (sorry)

Delphi-Quellcode:

unit TextShortener;

interface

uses
  Classes, Generics.Collections, SysUtils, StrUtils;

type
  IMeasureText = interface
    [ '{898BAD5F-200C-43D8-B60C-546FBE0B7E0A}' ]
    function GetCharWidth( const C: Char ): Integer;
    function GetTextWidth( const s: string ): Integer;
  end;

  IShortenText = interface
    [ '{D17025BA-4CBE-47DC-9180-8006EDF94FAE}' ]
    function ShortenText( const Source: string; const MaxLength: Integer; const ShortenSuffix: string = '...' ): string;
  end;

type
  TTextMeasureBase = class( TInterfacedObject, IMeasureText )
  private
    function GetCharWidth( const C: Char ): Integer; inline;
    function GetTextWidth( const s: string ): Integer; inline;
  protected
    function DoGetCharWidth( const C: Char ): Integer; virtual; abstract;
    function DoGetTextWidth( const s: string ): Integer; virtual;
  end;

  TCachedTextMeasure = class( TTextMeasureBase )
  private
    FInner: IMeasureText;
    FCache: TDictionary<Char, Integer>;
  protected
    function DoGetCharWidth( const C: Char ): Integer; override;
    function DoGetTextWidth( const s: string ): Integer; override;
  public
    constructor Create( const Inner: IMeasureText );
    destructor Destroy; override;
  end;

type
  TCharMeasureWidthDelegate = function( const C: Char )  : Integer of object;
  TTextMeasureWidthDelegate = function( const s: string ): Integer of object;

  TDelegatedTextMeasure = class( TTextMeasureBase )
  private
    FCharDelegate: TCharMeasureWidthDelegate;
    FTextDelegate: TTextMeasureWidthDelegate;
  protected
    function DoGetCharWidth( const C: Char ): Integer; override;
    function DoGetTextWidth( const s: string ): Integer; override;
  public
    constructor Create(
      const CharDelegate: TCharMeasureWidthDelegate;
      const TextDelegate: TTextMeasureWidthDelegate = nil );
  end;

type
  TTextShortenerBase = class( TInterfacedObject, IShortenText )
  private
    FTextMeasure: IMeasureText;
    function ShortenText(
      const Source       : string;
      const MaxLength    : Integer;
      const ShortenSuffix: string ): string; inline;
  protected
    function DoShortenText(
      const Source       : string;
      const MaxLength    : Integer;
      const ShortenSuffix: string;
      const TextMeasure  : IMeasureText ): string; virtual; abstract;
  public
    constructor Create( TextMeasure: IMeasureText );
  end;

type
  TCharBasedTextShortener = class( TTextShortenerBase )
  protected
    function DoShortenText(
      const Source       : string;
      const MaxLength    : Integer;
      const ShortenSuffix: string;
      const TextMeasure  : IMeasureText ): string; override;
  end;

type
  TTextBasedTextShortener = class( TTextShortenerBase )
  protected
    function DoShortenText(
      const Source       : string;
      const MaxLength    : Integer;
      const ShortenSuffix: string;
      const TextMeasure  : IMeasureText ): string; override;
  end;

implementation

{ TTextMeasureBase }

function TTextMeasureBase.DoGetTextWidth(

  const s: string ): Integer;
var
  lChar: Char;
begin
  Result := 0;
  for lChar in s do
    begin
      Inc( Result, GetCharWidth( lChar ) );
    end;
end;

function TTextMeasureBase.GetCharWidth( const C: Char ): Integer;
begin
  Result := DoGetCharWidth( C );
end;

function TTextMeasureBase.GetTextWidth( const s: string ): Integer;
begin
  Result := DoGetTextWidth( s );
end;

{ TCachedTextMeasure }

constructor TCachedTextMeasure.Create( const Inner: IMeasureText );
begin
  inherited Create;
  if not Assigned( Inner )
  then
    raise Exception.Create( 'Inner' );

  FCache := TDictionary<Char, Integer>.Create( );
  FInner := Inner;
end;

destructor TCachedTextMeasure.Destroy;
begin
  FCache.Free;
  inherited;
end;

function TCachedTextMeasure.DoGetCharWidth(

  const C: Char ): Integer;
begin
  if not FCache.TryGetValue( C, Result )
  then
    begin
      Result := FInner.GetCharWidth( C );
      FCache.Add( C, Result );
    end;
end;

function TCachedTextMeasure.DoGetTextWidth(

  const s: string ): Integer;
begin
  Result := FInner.GetTextWidth( s );
end;

{ TDelegatedTextMeasure }

constructor TDelegatedTextMeasure.Create(
  const CharDelegate: TCharMeasureWidthDelegate;
  const TextDelegate: TTextMeasureWidthDelegate );
begin
  inherited Create;

  if not Assigned( CharDelegate )
  then
    raise Exception.Create( 'CharDelegate' );

  FCharDelegate := CharDelegate;
  FTextDelegate := TextDelegate;
end;

function TDelegatedTextMeasure.DoGetCharWidth( const C: Char ): Integer;
begin
  Result := FCharDelegate( C );
end;

function TDelegatedTextMeasure.DoGetTextWidth( const s: string ): Integer;
begin
  if not Assigned( FTextDelegate )
  then
    Result := inherited
  else
    Result := FTextDelegate( s );
end;

{ TTextShortenerBase }

constructor TTextShortenerBase.Create( TextMeasure: IMeasureText );
begin
  inherited Create;
  if not Assigned( TextMeasure )
  then
    raise Exception.Create( 'TextMeasure' );

  FTextMeasure := TextMeasure;
end;

function TTextShortenerBase.ShortenText( const Source: string;
  const MaxLength: Integer; const ShortenSuffix: string ): string;
begin
  if MaxLength <= 0
  then
    raise EArgumentOutOfRangeException.Create( 'MaxLength' );

  Result := DoShortenText( Source, MaxLength, ShortenSuffix, FTextMeasure );
end;

{ TCharBasedTextShortener }

function TCharBasedTextShortener.DoShortenText(
  const Source       : string;
  const MaxLength    : Integer;
  const ShortenSuffix: string;
  const TextMeasure  : IMeasureText ): string;
var
  lSource                 : string;
  lChar                   : Char;
  lCharLength             : Integer;
  lSuffixLength           : Integer;
  lSourceLength           : Integer;
  lShortenedWithSuffix    : string;
  lShortendWithSuffixFound: Boolean;
begin
  lSuffixLength := 0;
  for lChar in ShortenSuffix do
    begin
      lSuffixLength := lSuffixLength + TextMeasure.GetCharWidth( lChar );
    end;

  if lSuffixLength > MaxLength
  then
    raise EArgumentOutOfRangeException.Create( 'SuffixLength > MaxLength' );

  Result                   := '';
  lSource                  := Trim( Source );
  lSourceLength            := 0;
  lShortendWithSuffixFound := False;

  for lChar in lSource do
    begin
      lCharLength := TextMeasure.GetCharWidth( lChar );

      if not lShortendWithSuffixFound and ( lSourceLength + lCharLength + lSuffixLength > MaxLength )
      then
        begin
          lShortenedWithSuffix     := Result + ShortenSuffix;
          lShortendWithSuffixFound := True;
        end;

      if lSourceLength + lCharLength > MaxLength
      then
        begin
          Result := lShortenedWithSuffix;
          Exit;
        end;

      Result := Result + lChar;
      Inc( lSourceLength, lCharLength );
    end;
end;

{ TTextBasedTextShortener }

function TTextBasedTextShortener.DoShortenText(
  const Source       : string;
  const MaxLength    : Integer;
  const ShortenSuffix: string;
  const TextMeasure  : IMeasureText ): string;
var
  lSource      : string;
  lSourceLength: Integer;
  lSuffixLength: Integer;
begin
  lSource       := Trim( Source );
  lSourceLength := TextMeasure.GetTextWidth( lSource );
  if lSourceLength > MaxLength
  then
    begin
      lSuffixLength := TextMeasure.GetTextWidth( ShortenSuffix );

      repeat
        SetLength( lSource, Length( lSource ) - 1 );
      until TextMeasure.GetTextWidth( lSource ) <= MaxLength - lSuffixLength;
    end;
  Result := lSource;
end;

end.

Delphi-Quellcode:

function GetTextBound(UseText: WideString; UseFont: WideString; UseSize: single; var bW: integer;
   var bH: integer; FontCollection: Pointer; UseStrFormat: integer): GPSTATUS; stdcall;
var
   Graphics: LONG_PTR;
   Fam: GpFontFamily;
   TempFont: GpFont;
   DC: HDC;
   strFormat: GPSTRINGFORMAT;
   boundingBox, layoutRect: TGPRectF;
begin
   Result := GenericError;
   strFormat := nil;
   Fam := nil;
   TempFont := nil;
   Graphics := 0;

   // Create matching font
   try
     GdipCheck(GdipCreateFontFamilyFromName(PWideChar(UseFont), FontCollection, Fam));
     if Assigned(Fam) then
     begin
       GdipCheck(GdipCreateFont(Fam, UseSize, 0, 2, TempFont));
       if Assigned(TempFont) then
       begin
         DC := GetDC(GetDesktopWindow);

         GdipCheck(GdipCreateStringFormat(0, 0, strFormat));
         GdipCheck(GdipCreateFromHDC(DC, Graphics));

         FillChar(boundingBox, SizeOf(boundingBox), 0);
         FillChar(layoutRect, SizeOf(layoutRect), 0);

         GdipCheck(GdipMeasureString(Graphics, PWideChar(UseText), Length(UseText), TempFont,
           @layoutRect, strFormat, @boundingBox, nil, nil));

         if Assigned(strFormat) then
           GdipCheck(GdipDeleteStringFormat(strFormat));

         bW := round(boundingBox.Width + 0.5);
         bH := round(boundingBox.Height{ + 0.5});

         if UseStrFormat <> 0 then
           Swap(bW, bH);

         if (bW <> 0) or (bH <> 0) then
           Result := OK;

         ReleaseDc(GetDesktopWindow, DC);
       end;
     end;
   finally
     if Graphics <> 0 then
       GdipCheck(GdipDeleteGraphics(Graphics));
     if Assigned(TempFont) then
       GdipCheck(GdipDeleteFont(TempFont));
     if Assigned(Fam) then
       GdipCheck(GdipDeleteFontFamily(Fam));
   end;
end;

Delphi-Quellcode:

function TShortener.CalculateCharWith(const C: Char): Integer;
var
  bW, bH: Integer;
begin
  GDIP_GetTextBound(C, SKAERO_CAPTIONFONT, SKAERO_CAPTIONFONTHEIGHT, bW, bH, nil, 0);
  Result := bW;
end;

Delphi-Quellcode:

type
  TShortener = class
   private
     FCaptionShortener: IShortenText;
   public
     function CalculateFixedCharWidth( const C: Char ): Integer;
     function CalculateCharWith( const C: Char ): Integer;
  end;

Delphi-Quellcode:

       
  SetRect(rc, 0, 0, gP.MainWidth + 400, 20);
   
  Shortener := TShortener.Create;
  Shortener.FCaptionShortener := TCharBasedTextShortener.Create(TCachedTextMeasure.Create(
    TDelegatedTextMeasure.Create(Shortener.CalculateCharWith)));

  FileName := Shortener.FCaptionShortener.ShortenText(gM.title, rc.Right, '...' );

  SKAERO_SetCTLText(gP.MainHandle, FileName);
  Shortener.Free;

Warum muss ich hier 400 addieren? ohne stimmt die länge nicht.
Wenn ich dann den Font ändere stimmt es wieder nicht.