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.

[venice2]

Auch das funktioniert nicht.

Delphi-Quellcode:

function GetEllipsis(s: string; R: TRect; DC:HDC): string;
begin
  Result := S;
  UniqueString(Result);

  R := Rect(1, 1, r.Right, 20);
  DrawTextEx(DC, PWideChar(Result), Length(Result), R, DT_CALCRECT or
    DT_END_ELLIPSIS or DT_MODIFYSTRING, nil);
  SetLength(Result, StrLen(PWideChar(Result)));
end;

oder.

Delphi-Quellcode:

function GetTextWidth(fnt: TFont; const text:string): Integer;
var
   dc: hdc;
   tsize : Windows.TSize;
begin
   dc := GetDC(0);
   SelectObject(DC, fnt.Handle);
   GetTextExtentPoint32(dc, PWideChar(text), Length(text), tsize);
   ReleaseDC(0, DC);
   Result := tsize.cx;
end;

frustrierend.

EDIT:
kümmert euch nicht mehr drum habe es selbst geregelt.

[hoika]

Hallo,
und wie hast Du es hinbekommen?

[venice2]

Zitat von hoika:

Hallo,
und wie hast Du es hinbekommen?

Es macht nicht viel sinn es aufzuführen weil die Lösung über mehrere Ebenen erreicht wird.
Hier ist die neue Funktion die im weiteren verlauf auf mehrere andere Funktionen verzweigt. (mehrere Ebenen)

Delphi-Quellcode:

function DrawEllipsisText(WinHandle: HWND; DC: Hdc; Text: WideString; TextRect: TRect;
  ColrARGB: COLORREF; UseFont: WideString; UseSize: Single; FontStyle: TFontStyle;
  ShadowOffset: Single; UseStrFormat: integer; WordWrap: BOOL): GPSTATUS;
var
  Width: integer;
  Fam: GpFontFamily;
  TempFont: GpFont;
  Graphics: LONG_PTR;
  rectF: TGPRectF;
  rc: TRect;
  strFormat: Pointer;
  boundingBox, layoutRect: TGPRectF;
begin

  Result := GenericError;
  Graphics := 0;
  strFormat := nil;
  TempFont := nil;
  Fam := nil;

  try
    GdipCheck(GdipCreateFromHDC(DC, Graphics));
    GdipCheck(GdipCreateFontFamilyFromName(PWideChar(UseFont), nil, Fam));
    if assigned(Fam) then
    begin
      GdipCheck(GdipCreateFont(Fam, UseSize, FontStyle, 2, TempFont));
      if assigned(TempFont) then
      begin
        GdipCheck(GdipCreateStringFormat(0, 0, strFormat));

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

        GdipCheck(GdipMeasureString(Graphics, PWideChar(Text), length(Text), TempFont, @layoutRect,
            strFormat, @boundingBox, nil, nil));

        Width := (TextRect.Right - TextRect.Left);

        if boundingBox.Width > Width then
        begin
          rectF := MakeRect(TextRect.Left, TextRect.Top, Width, TextRect.Bottom);
          rc.Left := round(rectF.x);
          rc.Top := round(rectF.y);
          rc.Bottom := round(rectF.Height);
          rc.Right := round(rectF.Width);

          UseStrFormat := GD_Ellipsis;
          Result := GdipCheck(DrawTextToDC(DC, Text, rc, ColrARGB, UseFont, UseSize, FontStyle,
              ShadowOffset, UseStrFormat, nil, False, 0, True));
        end
        else
          Result := GdipCheck(DrawTextToDC(DC, Text, TextRect, ColrARGB, UseFont, UseSize, FontStyle,
              ShadowOffset, UseStrFormat, nil, False, 0, WordWrap));
      end;
    end;
  finally
    if Graphics <> 0 then
      GdipCheck(GdipDeleteGraphics(Graphics));
    if assigned(TempFont) then
      GdipCheck(GdipDeleteFont(TempFont));
    if assigned(Fam) then
      GdipCheck(GdipDeleteFontFamily(Fam));
    if assigned(strFormat) then
      GdipCheck(GdipDeleteStringFormat(strFormat));
  end;


end;

Die ist sehr genau und tut was sie soll.
Aufruf.

Delphi-Quellcode:

        if gM.title <> '' then
        begin
          SKAERO_GetCaptionXY(x, y);
          if WinHandle = GetForegroundWindow then
            Color := SKAERO_ACTIVECAPTION
          else
            Color := SKAERO_INACTIVECAPTION;

          SetRect(rc, x, y, gP.MainWidth -70, SKAERO_CAPTIONFONTHEIGHT + 4);
          GDIP_DrawEllipsisText(WinHandle, SrcDC, gM.title, rc, Color,
            SKAERO_CAPTIONFONT, SKAERO_CAPTIONFONTHEIGHT, FontStyleBoldItalic, -1, 0);
        end else
        SKAERO_SetCTLText(WinHandle, 'KVideo Player64');

[venice2]

Die länge von Ellipsis Text stimmt nun habe aber ein ähnliches weiteres Problem.
Ich Ownerdraw mein Edit Control mit GDI+ dazu übergebe ich folgende Parameter.

Delphi-Quellcode:

edInput.SetFont(SKAERO_PUSHBUTFONTSIZE, PWideChar(SKAERO_TEXTFONT),
  FontStyleBoldItalic, SKAERO_ACTIVECAPTION, SKAERO_INACTIVECAPTION,
  True, -1);

Danach konvertiere ich den GDI+ Font in einen HFont damit das Edit den gleichen Font hat wie der den ich zeichne. Stimmt soweit.

Delphi-Quellcode:

procedure TSkinEdit.SetFont(nPointSize: Integer; FontName: String; FontStyle: TFontStyle;
  AktForecolor, InAktForecolor: COLORREF; Shadow: Boolean; ShadowOffset: Single);
var
  Fam: GpFontFamily;
  Gpf: GpFont;
  Graphics: LONG_PTR;
  DC: HDC;
  lf: LOGFONTW;

begin
  Graphics := 0;
  Gpf := nil;
  Fam := nil;

  if Handle <> 0 then
  begin
    FShadow := Shadow;
    FShadowColor := ShadowColor;
    FShadowOffset := ShadowOffset;
    FAktForecolor := AktForecolor;
    FInAktForecolor := InAktForecolor;
    FPointSize := nPointSize;
    FFontName := FontName;
    FFontStyle := FontStyle;

    DC := GetDC(0);
    try
      if GdipCheck(GdipCreateFromHDC(DC, Graphics)) = OK then
      begin
        if GdipCheck(GdipCreateFontFamilyFromName(PWideChar(FFontName), nil, Fam)) = OK then
        begin
          if assigned(Fam) then
          begin
            GdipCheck(GdipCreateFont(Fam, FPointSize, FontStyle, 2, Gpf));
            if assigned(Gpf) then
            begin
              GdipCheck(GdipGetLogFontW(Gpf, Graphics, lf));
              _hfont := CreateFontIndirectW(lf);
              SendMessageW(Handle, WM_SETFONT, WPARAM(_hfont), 0);
            end;
          end;
        end;
      end;
    finally
      ReleaseDC(0, DC);
      if Graphics <> 0 then
        GdipCheck(GdipDeleteGraphics(Graphics));
      if assigned(Gpf) then
        GdipCheck(GdipDeleteFont(Gpf));
      if assigned(Fam) then
        GdipCheck(GdipDeleteFontFamily(Fam));
    end;
  end;
end;

Aber das Caret Offset ist nicht gleich Gezeichneter Font -> Edit Font.

Der blinkende Cursor ist immer ein paar Pixel daneben abhängig von dem was ich schreibe.
Wie kann ich das beheben?