//=============================================================================
//  フォーム生成時の処理
//  Edit1, Edit2 とのフォント名を異なるものにする
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
begin
  Edit1.Font.Size := 20;
  Edit2.Font.Size := 20;

  Edit1.Font.Name := 'Meiryo';
  Edit2.Font.Name := 'Wingdings';
end;

//=============================================================================
//  TEdit の OnChange イベント処理
//  Edit1, Edit2 の文字(コードポイント)を同じにする
//=============================================================================
procedure TForm1.Edit1Change(Sender: TObject);
begin
  if Sender = Edit1 then begin
    Edit2.Text := Edit1.Text;
  end else begin
    Edit1.Text := Edit2.Text;
  end;
end;

implementation

uses
  MECSUtils;

{$R *.dfm}

//-----------------------------------------------------------------------------
//  EnumFontFamiliesのコールバック関数
//-----------------------------------------------------------------------------
function EnumFontFamProc(lpelf: PEnumLogFont; lpntm: PNewTextMetric;
  nFontType: Integer; lParam: TStrings): Integer; stdcall;
var
  LFontName  : String;
begin
  Result := 1;

  LFontName := lpelf.elfLogFont.lfFaceName;
  //縦書き用フォントは除外
  if Pos('@', LFontName) = 0 then begin
    lParam.Add(LFontName);
  end;
end;

//=============================================================================
//  フォーム生成時の処理
//  コンボボックスにフォント名のリストをセット
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
var
  LDC    : HDC;
  LIndex : Integer;
begin
  //フォント名リストの作成
  //全フォントのリストを取得する関数はEnumFontFamiliesEx
  ComboBox1.Clear;
  ComboBox1.Sorted := True;
  LDC := GetDC(Handle);
  try
    EnumFontFamilies(LDC, nil, @EnumFontFamProc, LPARAM(ComboBox1.Items));
    LIndex := ComboBox1.Items.IndexOf(Self.Font.Name);
    ComboBox1.ItemIndex := LIndex;
  finally
    ReleaseDC(Handle, LDC);
  end;
  Edit2.Font.Name := ComboBox1.Text;
  Edit1.Text := '#$1F6BA#$1F6AB#$1F52F';
end;

//=============================================================================
//  Edit1に入力したコードポイントの値を実際の文字にして表示
//  サロゲートペアな文字の場合はサロゲートペアに分解してそのコードを表示
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  LStrList : TStringList;
  LText    : string;
  LText16  : string;
  LoopCnt  : Integer;
begin
  Edit2.Text := '';

  LStrList := TStringList.Create;
  try
    //デリミタの設定して文字列をセット
    LStrList.Delimiter       := '#';
    LStrList.StrictDelimiter := True;
    LStrList.DelimitedText   := Edit1.Text;

    //1文字分のコードポイントの値を取り出して順番に文字列に追加
    LText := '';
    for LoopCnt := 0 to LStrList.Count - 1 do begin
      if Trim(LStrList[LoopCnt]) <> '' then begin
        LText := LText + CodePointToUTF16(StrToUInt(LStrList[LoopCnt]));
      end;
    end;
  finally
    FreeAndNil(LStrList);
  end;
  Edit2.Text := LText;

  //対象の文字列
  LText := Edit2.Text;

  LText16 := '';
  for LoopCnt := 1 to Length(LText) do begin
    LText16 := LText16 + '#' + Format('$%.4x', [Ord(LText[LoopCnt]), 4]);
  end;
  Edit3.Text := LText16;
end;

//=============================================================================
//  ComboBox1のOnClickイベント
//  コンボボックスでフォント名を選択したらそのフォントで文字を再表示
//=============================================================================
procedure TForm1.ComboBox1Click(Sender: TObject);
begin
  Edit2.Font.Name := ComboBox1.Items[ComboBox1.ItemIndex];
end;

unit Unit1;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes,
  Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.ExtCtrls;

type
  TForm1 = class(TForm)
    procedure FormPaint(Sender: TObject);
  private
    { Private 宣言 }
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

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

{$R *.dfm}

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

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

{ TMyCanvas }

procedure TMyCanvas.TextOut(X, Y: Integer; const Text: string);
const
  D2D1_DRAW_TEXT_OPTIONS_ENABLE_COLOR_FONT = $00000004;
var
  TextRange: TDwriteTextRange;
  TextLayout: IDWriteTextLayout;
begin
  OleCheck(DWriteFactory.CreateTextLayout(PWideChar(Text),
                                   Length(Text),
                                   Font.Handle,
                                   0,
                                   0,
                                   TextLayout));
  TextRange.startPosition := 0;
  TextRange.length := Length(Text);
  TextLayout.SetWordWrapping(DWRITE_WORD_WRAPPING_NO_WRAP);

  RequiredState([csHandleValid, csFontValid, csBrushValid]);
  if CheckWin32Version(6, 3) then begin
    TextLayout.SetFontFamilyName('Segoe UI Emoji', TextRange);
    TextLayout.SetFontSize(11.5, TextRange);
    RenderTarget.DrawTextLayout(D2D1PointF(x - 0.5, y - 0.5),
                                TextLayout,
                                Font.Brush.Handle,
                                D2D1_DRAW_TEXT_OPTIONS_ENABLE_COLOR_FONT);
  end else begin
    TextLayout.SetFontFamilyName('Segoe UI Symbol', TextRange);
    TextLayout.SetFontSize(15.5, TextRange);
    RenderTarget.DrawTextLayout(D2D1PointF(x - 0.5, y - 0.5),
                                TextLayout,
                                Font.Brush.Handle,
                                D2D1_DRAW_TEXT_OPTIONS_NONE);
  end;
end;

end.

procedure TForm1.Button1Click(Sender: TObject);
var
  FD2DCanvas: TDirect2DCanvas;
begin
  FD2DCanvas := TMyCanvas.Create(Label1.Canvas.Handle, ClientRect);
  try
    FD2DCanvas.BeginDraw;
    FD2DCanvas.RenderTarget.Clear (D2D1ColorF(clWhite));
    FD2DCanvas.TextOut(0, 0, #$1F6BA#$1F6AB#$1F52F);
    FD2DCanvas.EndDraw;
  finally
    FD2DCanvas.Free;
  end; 
end;

<!doctype HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">
<html>
<head>
<html lang="ja">
<meta http-equiv="Content-Type" content="text/html; charset=EUC-JP">
</head>
<body>
</body>
</html>

implementation

uses
  MSHTML;

{$R *.dfm}

//=============================================================================
//  フォーム生成時の処理
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
begin
  Edit1.Text := ExpandFileName('test.html');
  WebBrowser1.Navigate(Edit1.Text);
end;

//=============================================================================
//  designMode開始
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
begin
  (WebBrowser1.Document as IHTMLDocument2).designMode := 'on';
end;

//=============================================================================
//  designMode終了
//=============================================================================
procedure TForm1.Button2Click(Sender: TObject);
begin
  (WebBrowser1.Document as IHTMLDocument2).designMode := 'off';
end;

//=============================================================================
//  FreeTypeライブラリを使用した文字のグリフ(字形)データの取得例
//  1文字だけの簡単な例
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  LFTLibrary    : FT_Library;
  LError        : FT_Error;
  LByteStream   : TBytesStream;
  LFontFilePath : string;
  LLineHeight   : Integer;
  LCodePoint    : FT_ULong;
  LFTFace       : FT_Face;
  LGlyphIndex   : FT_UInt;
  LGlyphSlot    : FT_GlyphSlot;
  LDrawLeft     : Integer;
  LDrawTop      : Integer;
begin
  //文字を描画する背景を塗り潰す
  Label1.Canvas.Brush.Style := bsClear;
  Label1.Canvas.Brush.Color := clSilver;
  Label1.Canvas.FillRect(Label1.Canvas.ClipRect);


  //文字の高さ(ピクセル数)
  LLineHeight := 80;

  //FreeTypeライブラリの初期化
  LError := FT_Init_FreeType(LFTLibrary);
  if LError <> 0 then Exit;


  LByteStream := TBytesStream.Create;
  try
    //フォントファイルのデータをメモリストリームに読み込む
    LFontFilePath := ExpandFileName('.\seguiemj.ttf');
    LByteStream.LoadFromFile(LFontFilePath);

    //そのフォントデータからFT_Fac3オブジェクトを取得
    FT_New_Memory_Face(LFTLibrary,
                       @LByteStream.Bytes[0],
                       LByteStream.Size,
                       0,
                       LFTFace );

    //描画するピクセルのサイズを設定
    FT_Set_Pixel_Sizes(LFTFace, 0, LLineHeight);

    //グリフデータを取得する文字のコードポイント
    LCodePoint := $1F61C;

    //コードポイントの値から文字のグリフ(字形)のインデックスを取得
    LGlyphIndex := FT_Get_Char_Index(LFTFace, LCodePoint);
    //FT_Face.GlyphSlotとしてグリフのデータのポインタを取得
    FT_Load_Glyph(LFTFace, LGlyphIndex, FT_LOAD_DEFAULT);

    //グリフのビットマップデータを取得
    LGlyphSlot := LFTFace.glyph;
    FT_Render_Glyph(LGlyphSlot, FT_RENDER_MODE_NORMAL);

    //描画開始位置を指定
    LDrawLeft := 10;
    LDrawTop  := LLineHeight - LFTFace.glyph.bitmap_top;

    //取得したビットデータをTBitmapにして描画
    DrawFreeTypeBitmap(LGlyphSlot.bitmap, LDrawLeft, LDrawTop);
  finally
    FreeAndNil(LByteStream);
  end;

  //終了処理
  FT_Done_Face(LFTFace);
  FT_Done_FreeType(LFTLibrary) ;
end;

//-----------------------------------------------------------------------------
//  FreeTypeで取得したビットマップデータをTBitmapのデータにして描画
//  AFTBitmap : パレット情報なしの256色のビットマップのバイトデータ
//              データはボトムアップ
//  X         : 描画会開始X座標値
//  Y         : 描画開始Y座標値
//
//  ここでは32ビットのアルファチャンネル付きのビットマプに変換してから描画
//-----------------------------------------------------------------------------
procedure TForm1.DrawFreeTypeBitmap(AFTBitmap: FT_Bitmap; X, Y: Integer);
type
  TRGBQArray = array [0..High(Integer) div 4 - 1] of RGBQUAD;
  PRGBQArray = ^TRGBQArray;
var
  LBitmap    : TBitmap;
  LBytePos   : Integer;
  LPosX      : Integer;
  LPosY      : Integer;
  LScanArray : PRGBQArray;
  LColorQuad : RGBQUAD;
  LByte      : Byte;
begin
  LBitmap := TBitmap.Create;
  try
    LBitmap.SetSize(AFTBitmap.width, AFTBitmap.rows);
    LBitmap.PixelFormat := pf32bit;
    LBitmap.AlphaFormat := afDefined;

    LBytePos := 0;
    for LPosY := 0 to LBitmap.Height - 1 do begin
      LScanArray := LBitmap.ScanLine[LPosY];

      for LPosX :=0 to LBitmap.Width - 1 do begin
        LByte := AFTBitmap.buffer[LBytePos];
        if LByte <> $00 then begin
          LByte := $00;
        end else begin
          LByte := $FF;
        end;
        LColorQuad.rgbRed      := LByte;
        LColorQuad.rgbGreen    := LByte;
        LColorQuad.rgbBlue     := LByte;
        LColorQuad.rgbReserved := $FF;

        LScanArray[LPosX] := LColorQuad;

        inc(LBytePos);
      end;
    end;

    Label1.Canvas.Draw(X, y, LBitmap);
  finally
    FreeAndNil(LBitmap);
  end;
end;

implementation

{$R *.dfm}

const
  FT_LOAD_COLOR = 1 shl 20;


//=============================================================================
//  FreeTypeライブラリを使用してカラー絵文字を描画
//  MicrosoftのEmoji(Color Font)のCOLR/CPAL対応のFreeTypeライブラリを使用
//
//  Windows 10 のSegoe UI Emojiフォントをコピーしてテスト
//  1文字だけの簡単な例
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  LFTLibrary    : FT_Library;
  LError        : FT_Error;
  LByteStream   : TBytesStream;
  LFontFilePath : string;
  LLineHeight   : Integer;
  LCodePoint    : FT_ULong;
  LFTFace       : FT_Face;
  LGlyphIndex   : FT_UInt;
  LGlyphSlot    : FT_GlyphSlot;
  LDrawLeft     : Integer;
  LDrawTop      : Integer;
begin
  //文字を描画する背景を塗り潰す
  Label1.Canvas.Brush.Style := bsClear;
  Label1.Canvas.Brush.Color := clSilver;
  Label1.Canvas.FillRect(Label1.Canvas.ClipRect);


  //文字の高さ(ピクセル数)
  LLineHeight := 80;

  //FreeTypeライブラリの初期化
  LError := FT_Init_FreeType(LFTLibrary);
  if LError <> 0 then Exit;


  LByteStream := TBytesStream.Create;
  try
    //フォントファイルのデータをメモリストリームに読み込む
    LFontFilePath := ExpandFileName('.\seguiemj.ttf');
    LByteStream.LoadFromFile(LFontFilePath);

    //そのフォントデータからFT_Fac3オブジェクトを取得
    FT_New_Memory_Face(LFTLibrary,
                       @LByteStream.Bytes[0],
                       LByteStream.Size,
                       0,
                       LFTFace );

    //描画するピクセルのサイズを設定
    FT_Set_Pixel_Sizes(LFTFace, 0, LLineHeight);

    //グリフデータを取得する文字のコードポイント
    LCodePoint := $1F61C;

    //コードポイントの値から文字のグリフ(字形)のインデックスを取得
    LGlyphIndex := FT_Get_Char_Index(LFTFace, LCodePoint);
    //FT_Face.GlyphSlotとしてグリフのデータのポインタを取得
    FT_Load_Glyph(LFTFace, LGlyphIndex, FT_LOAD_COLOR);

    //グリフのビットマップデータを取得
    LGlyphSlot := LFTFace.glyph;
    FT_Render_Glyph(LGlyphSlot, FT_RENDER_MODE_NORMAL);

    //描画開始位置を指定
    LDrawLeft := 10;
    LDrawTop  := LLineHeight - LFTFace.glyph.bitmap_top;

    //取得したビットデータをTBitmapにして描画
    DrawFreeTypeBitmap(LGlyphSlot.bitmap, LDrawLeft, LDrawTop);
  finally
    FreeAndNil(LByteStream);
  end;

  //終了処理
  FT_Done_Face(LFTFace);
  FT_Done_FreeType(LFTLibrary) ;
end;

//-----------------------------------------------------------------------------
//  FreeTypeで取得したビットマップデータをTBitmapのデータにして描画
//  AFTBitmap : ビットマップのバイトデータ
//              データはボトムアップ
//  X         : 描画会開始X座標値
//  Y         : 描画開始Y座標値
//
//  32ビットのアルファチャンネル付きのビットマプとして描画
//-----------------------------------------------------------------------------
procedure TForm1.DrawFreeTypeBitmap(AFTBitmap: FT_Bitmap; X, Y: Integer);
type
  TRGBQArray = array [0..High(Integer) div 4 - 1] of RGBQUAD;
  PRGBQArray = ^TRGBQArray;
var
  LIsColor   : Boolean;
  LIncValue  : Integer;
  LBitmap    : TBitmap;
  LBytePos   : Integer;
  LPosX      : Integer;
  LPosY      : Integer;
  LScanArray : PRGBQArray;
  LColorQuad : RGBQUAD;
  LByte      : Byte;
  LBValue    : Byte;
  LGValue    : Byte;
  LRValue    : Byte;
  LAValue    : Byte;
begin
  LBitmap := TBitmap.Create;
  try
    LBitmap.SetSize(AFTBitmap.width, AFTBitmap.rows);
    LBitmap.PixelFormat := pf32bit;
    LBitmap.AlphaFormat := afDefined;

    LIncValue := 1;
    LIsColor := AFTBitmap.width = AFTBitmap.pitch div 4;
    if LIsColor then LIncValue := 4;

    LBytePos := 0;
    for LPosY := 0 to LBitmap.Height - 1 do begin
      LScanArray := LBitmap.ScanLine[LPosY];

      for LPosX :=0 to LBitmap.Width - 1 do begin
        if LIsColor then begin
          LRValue := AFTBitmap.buffer[LBytePos + 0];
          LGValue := AFTBitmap.buffer[LBytePos + 1];
          LBValue := AFTBitmap.buffer[LBytePos + 2];
          LAValue := AFTBitmap.buffer[LBytePos + 3];
        end else begin
          LByte := AFTBitmap.buffer[LBytePos];
          if LByte <> $00 then begin
            LRValue := $00;
            LGValue := $00;
            LBValue := $00;
            LAValue := $FF;
          end else begin
            LRValue := $FF;
            LGValue := $FF;
            LBValue := $FF;
            LAValue := $FF;
          end;
        end;

        LColorQuad.rgbRed      := LRValue;
        LColorQuad.rgbGreen    := LGValue;
        LColorQuad.rgbBlue     := LBValue;
        LColorQuad.rgbReserved := LAValue;

        LScanArray[LPosX] := LColorQuad;

        inc(LBytePos, LIncValue);
      end;
    end;

    Label1.Canvas.Draw(X, y, LBitmap);
  finally
    FreeAndNil(LBitmap);
  end;
end;