Delphi の ImageCollection へ Unicode絵文字をカラーで追加

Delphi の VirtualImageList(TVirtualImageList) を利用して、絵文字をアイコンとして、ImageCollection(TImageCollection) へ Unicode絵文字をカラーで動的に追加したい

通常の Canvas で TextOut するとモノクロになるので、Direct2D を使うんだとか

また、生成する画像サイズに収まるようにするため、フォントサイズを変化させながら収まるサイズを探しています

で、出来た関数

※投入後、VirtualImageList.AutoFill := False → True で反映されます

VirtualImageList が高DPIへサイズ調整するので、利用サイズより大きめで作成しておきましょう

uses Vcl.Graphics, Vcl.BaseImageCollection, Vcl.ImageCollection, System.ImageList, Vcl.ImgList, Vcl.VirtualImageList, Vcl.ComCtrls,
     Vcl.Direct2D, Winapi.D2D1

function AddImageCollectionItemFromEmoji(AImageCollection: TImageCollection; AEmoji: string; AWidth: Integer = 32; AHeight: Integer = 32; AItemName: string = ''; AMaxFontSize: Integer = 32): Integer;
var
    Bitmap: TBitmap;
    CollectionItem: TImageCollectionItem;
    SourceItem: TImageCollectionSourceItem;
    D2DCanvas: TDirect2DCanvas;
    Size: Integer;
begin
    Bitmap := TBitmap.Create;
    try
        Bitmap.SetSize(AWidth, AHeight);
        Bitmap.PixelFormat := pf32bit;
        Bitmap.AlphaFormat := afPremultiplied;

        D2DCanvas := TDirect2DCanvas.Create(Bitmap.Canvas, Rect(0, 0, AWidth, AHeight));
        try
            D2DCanvas.BeginDraw;
            
            
            // 背景を透過
            D2DCanvas.RenderTarget.Clear(D2D1ColorF(0, 0, 0, 0));
            

            // キャンバスに収まるフォントサイズを探す
            D2DCanvas.Font.Name := 'Segoe UI Emoji';
            for Size := AMaxFontSize downto 8 do begin
                D2DCanvas.Font.Size := Size;
                if (D2DCanvas.TextWidth(AEmoji) <= (Bitmap.Width)) and (D2DCanvas.TextHeight(AEmoji) <= (Bitmap.Height)) then begin
                    Break;
                end;
            end;

            // 中央寄せ
            D2DCanvas.Font.Handle.SetTextAlignment(DWRITE_TEXT_ALIGNMENT_CENTER);
            D2DCanvas.Font.Handle.SetParagraphAlignment(DWRITE_PARAGRAPH_ALIGNMENT_CENTER);

            // Direct2Dで描画
            D2DCanvas.RenderTarget.DrawText( //
              PWideChar(AEmoji), //
              Length(AEmoji), //
              D2DCanvas.Font.Handle, //
              D2D1RectF(0, 0, AWidth, AHeight), //
              D2DCanvas.Brush.Handle, //
              D2D1_DRAW_TEXT_OPTIONS_ENABLE_COLOR_FONT);

            D2DCanvas.EndDraw;
        finally
            D2DCanvas.Free;
        end;

        CollectionItem := AImageCollection.Images.Add;
        CollectionItem.Name := AItemName;
        Result := CollectionItem.Index;

        SourceItem := CollectionItem.SourceImages.Add;
        SourceItem.Image.Assign(Bitmap);
    finally
        Bitmap.Free;
    end;
end;