Anzeige farbiger Emoji (unicode Zeichen) mit Segoe UI Emoji Schrift in Delphi

[Uwe Raabe]

Hier noch der Quelltext der Form-Unit:

Delphi-Quellcode:

unit Unit299;

interface

uses
  Vcl.Forms;

type
  TForm299 = class(TForm)
    procedure FormPaint(Sender: TObject);
  public
  end;

var
  Form299: TForm299;

implementation

uses
  Winapi.D2D1,
  System.Win.ComObj,
  Vcl.Graphics, Vcl.Direct2D;

{$R *.dfm}

type
  TMyCanvas = class(TDirect2DCanvas)
  public
    procedure TextOut(X, Y: Integer; const Text: string); override;
  end;

procedure TMyCanvas.TextOut(X, Y: Integer; const Text: string);
var
  TextRange: TDwriteTextRange;
  TextLayout: IDWriteTextLayout;
  TextMetrics: TDWriteTextMetrics;
begin
  OleCheck(DWriteFactory.CreateTextLayout(PWideChar(Text), Length(Text),
    Font.Handle, 0, 0, TextLayout));
  TextRange.startPosition := 0;
  TextRange.length := Length(Text);
  if fsUnderline in Font.Style then
    TextLayout.SetUnderline(True, TextRange);

  if fsStrikeOut in Font.Style then
    TextLayout.SetStrikethrough(True, TextRange);

  TextLayout.SetWordWrapping(DWRITE_WORD_WRAPPING_NO_WRAP);

  RequiredState([csHandleValid,  csFontValid, csBrushValid]);
  if Brush.Style <> bsClear then
  begin
    TextLayout.GetMetrics(TextMetrics);
    RenderTarget.FillRectangle(D2D1RectF(X, Y,
      X+TextMetrics.widthIncludingTrailingWhitespace,
      Y+TextMetrics.height), Brush.Handle);
  end;

  RenderTarget.DrawTextLayout(D2D1PointF(x-0.5, y-0.5), TextLayout,
    Font.Brush.Handle, 4);
end;

procedure TForm299.FormPaint(Sender: TObject);
var
  FD2DCanvas: TDirect2DCanvas;
begin
  FD2DCanvas := TMyCanvas.Create(Canvas.Handle, ClientRect);
  try
    FD2DCanvas.BeginDraw;
    FD2DCanvas.TextOut(10, 10, '😍😀😊😜☹😐😅😎❤😘😂😃💋💖😋😭😇🙄💩🙈🙉🙊🔞');
    FD2DCanvas.EndDraw;
  finally
    FD2DCanvas.Free;
  end;
end;

end.