Einzelnen Beitrag anzeigen

Benutzerbild von KodeZwerg
KodeZwerg

Registriert seit: 1. Feb 2018
3.691 Beiträge
 
Delphi 11 Alexandria
 
#14

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

  Alt 18. Jun 2018, 17:42
Vielleicht kann ein Umweg über ein Bild da helfen?
using fonts as images in delphi 7
Zitat:
Delphi-Quellcode:
const
   CHESS_WHITE_QUEEN = #$2654;
   CHESS_WHITE_KING = #$2655;
   CHESS_WHITE_ROOK = #$2656;
   CHESS_WHITE_BISHOP = #$2657;
   CHESS_WHITE_KNIGHT = #$2658;
   CHESS_WHITE_PAWN = #$2659;

   CHESS_BLACK_QUEEN = #$265A;
   CHESS_BLACK_KING = #$265B;
   CHESS_BLACK_ROOK = #$265C;
   CHESS_BLACK_BISHOP = #$265D;
   CHESS_BLACK_KNIGHT = #$265E;
   CHESS_BLACK_PAWN = #$265F;

function CharToBitmap(sFontName: String; c: WideChar; cBackColor, cFontColor, cOutlineColor: TColor;
  OutlineSize: Integer; bmp: TBitmap): Boolean;
var
  r: TRect;
  OtmSize: Integer;
  pTm: POutlineTextMetric;
  LogFont: TLogFont;
begin
  Result := False;

  //destination rect
  r := Rect(0, 0, bmp.Width, bmp.Height);

  //set new font
  bmp.Canvas.Font.Name := sFontName;
  bmp.Canvas.Font.Style := [fsBold];
  bmp.Canvas.Font.Size := 10;

  //fill background
  bmp.Canvas.Brush.color := cBackColor;
  bmp.Canvas.FillRect(r);

  //get font metrics
  OtmSize := GetOutlineTextMetrics(bmp.Canvas.Handle, SizeOf(TOutlineTextMetric), nil);
  if OtmSize > 0 then
  begin
    //reserve memory
    GetMem(pTm, OtmSize);
    try
      pTm^.otmSize := OtmSize; //set size

      if GetOutlineTextMetrics(bmp.Canvas.Handle, OtmSize, pTm) <> 0 then
      begin
        //fill whole height
        bmp.Canvas.Font.Height := - bmp.Height;

        BeginPath(bmp.Canvas.handle);

        SetBKMode(bmp.Canvas.Handle, TRANSPARENT);

        DrawTextW(bmp.canvas.handle, @c, 1, r, DT_SINGLELINE or
          DT_CENTER or DT_VCENTER);

        EndPath(bmp.Canvas.handle);
        bmp.Canvas.Brush.color := cFontColor;
        bmp.Canvas.pen.color := cOutlineColor;
        bmp.Canvas.pen.width := OutlineSize;
        StrokeAndFillPath(bmp.Canvas.Handle);

        Result := True;
      end;
    finally
      FreeMem(pTm);
    end;
  end;
end;

procedure TForm1.Button4Click(Sender: TObject);
var
  bmp: TBitmap;
begin
  bmp := TBitmap.create;
  try
    bmp.width := 100;
    bmp.height := 100;
    //white piece
    CharToBitmap('Chess Merida Unicode', CHESS_WHITE_BISHOP,
      clGreen,
      clBlack,
      clWhite,
      bmp.height div 80,
      bmp);
  Image1.Picture.Assign(bmp);

    //black piece
    CharToBitmap('Chess Merida Unicode', CHESS_BLACK_KING,
      clGreen,
      clBlack,
      clWhite,
      bmp.height div 80,
      bmp);

    Image2.Picture.Assign(bmp);
  finally
    bmp.Free;
  end;
end;
Links I look:
https://support.microsoft.com/en-us/...size-of-a-font
http://www.fontcubes.com/Chess-7.font
http://mip.noekeon.org/HTMLTTChess/c...a_unicode.html
Gruß vom KodeZwerg
  Mit Zitat antworten Zitat