VCLのDirectWriteで背景透過文字描画 (ID:151209)

名前

ホームページ(ブログ、Twitterなど)のURL (省略可)

本文

Delphi2007以来久しぶりにDelphi 11 Community Editionを使っているものです。
情報が少ないVCLのDirectWriteを四苦八苦しながら使っているのですが、下記コードで躓いています。
やりたいことは……
1. アルファ情報付きBitmapを作成し背景を透明色で塗りつぶす
2. DirectWriteでBitmap.Canvasに文字を描画する
3. BitmapをPngにコピーする
4. Pngをファイルに保存する
ということでとりあえず動作しているですが、よく見ると背景を透明色にしているにもかかわらず文字の縁に黒色が残ってしまっています。透明な背景に文字が綺麗に馴染むようにしたいのですが何かやり方を間違えていますでしょうか。英語でググってみたりChatGPT先生にも聞いてみましたが有益な情報は得られず挫けそうです。ご教授ください。

uses
  Winapi.D2D1, Vcl.Direct2D, Vcl.Graphics, Vcl.Imaging.pngimage;

procedure TForm1.Button1Click(Sender: TObject);
const
  FileName = 'C:\Users\xxxx\ドキュメント\test.png';
  Text = '文字サンプル';
  w = 500;
  h = 300;
var
  D2DCanvas: TDirect2DCanvas;
  TextFormat: IDWriteTextFormat;
  TextLayout: IDWriteTextLayout;
  Bmp: TBitmap;
  Png: TPngImage;
  p: TD2D1Point2F;
  r: TRect;
begin
  Bmp := TBitmap.Create;
  Bmp.AlphaFormat := afDefined;
  Bmp.Transparent := true;
  Bmp.SetSize(w,h);
  r := Rect(0,0,w,h);
  D2DCanvas := TDirect2DCanvas.Create(Bmp.Canvas,r);
  D2DCanvas.BeginDraw;
  D2DCanvas.RenderTarget.Clear(D2D1ColorF(0.0,0.0,0.0,0.0));
  DWriteFactory.CreateTextFormat(PWideChar('メイリオ'),nil,DWRITE_FONT_WEIGHT_NORMAL,DWRITE_FONT_STYLE_NORMAL,DWRITE_FONT_STRETCH_NORMAL,40,'ja-jp',TextFormat);
  DWriteFactory.CreateTextLayout(PWideChar(Text),Length(Text),TextFormat,0,0,TextLayout);
  TextLayout.SetWordWrapping(DWRITE_WORD_WRAPPING_NO_WRAP);
  D2DCanvas.Font.Brush.Color := clBlue;
  p.x := 100;
  p.y := 100;
  D2DCanvas.RenderTarget.DrawTextLayout(p,TextLayout,D2DCanvas.Font.Brush.Handle,D2D1_DRAW_TEXT_OPTIONS_NONE);
  D2DCanvas.EndDraw;
  D2DCanvas.Free;
  Png := TPngImage.Create;
  Png.Assign(Bmp);
  Png.SaveToFile(FileName);
  Png.Free;
  Bmp.Free;
end;

←解決時は質問者本人がここをチェックしてください。

戻る