VCLのDirectWriteで背景透過文字描画

解決

soi 2023-11-05 21:39:44 No: 151209

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;

AAAAA 2023-11-05 23:44:41 No: 151210

文字描画でアンチエイリアスが利いてるからだと思う

soi 2023-11-06 08:54:05 No: 151211

返信ありがとうございます。やはりアンチエイリアスがかかるときの背景色にアルファ成分は加味されないということでしょうか。できないとしたら残念です……。

AAAAA 2023-11-06 10:31:46 No: 151212

PixelFormat := pf32bit; でやれば黒色は残らない

mam URL 2023-11-06 12:32:15 No: 151214

AAAAA様が解決策を既に提示されていますが、Direct2Dキャンバスの使い方サンプルを公開しています。
https://mam-mam.net/delphi/vcl_direct2d_canvas.html

soi 2023-11-06 17:40:08 No: 151215

AAAAA様　解決策のご提示ありがとうございます。ただ残念ながらBmp.PixelFormat:=pf32bit;をBmp.Createのあとに追加しても結果は変わりませんでした。私のやり方の問題のような気がしますので、引き続きいろいろ探ってみます。

soi 2023-11-06 17:41:35 No: 151216

mam様　Direct2Dキャンバスの使い方サンプルありがとうございます。実はすでにこのページは見つけております。有益な情報を公開していただき改めてお礼申し上げます。まだ解決には至っておりませんが引き続き参考にさせていただきます。

soi URL 2023-11-06 18:35:28 No: 151217

参考までに出力した文字を拡大した画像をアップロードしました（※広告がうるさくてすいません）。上が今回のコードで吐き出したもの、下はPowerPointで文字を「図として保存」でPNGに吐き出したものです。なんとか下のようにしたいのですが……。

soi 2023-11-06 18:36:11 No: 151218

本文にURLを記入するのを忘れました。
https://ibb.co/7JyTf8C

AAAAA 2023-11-06 20:30:02 No: 151219

通常の所は AlpheBalend 255 で Canvas 描画　
アンチエイリアスの所は Canvas と Font.Color で計算でなくそのまま Canvas に描画してアンチエイリアスを AlphaBlend で表現
テキスト以外は AlphaBlend 0

これやらんと無理だね　

ScanLine ならできるだろうけど

soi 2023-11-07 09:27:38 No: 151223

AAAAA様　力業となると白旗ですね（涙）。DirectWriteの仕様ということなのでしょうか。透明色背景はやっかいなものです。気長に情報を集めてみようと思います。回答にお時間を割いていただきありがとうございました。

mam 2023-11-07 10:43:31 No: 151224

D2DCanvas.RenderTarget.Clear(D2D1ColorF(0.0,0.0,0.0,0.0));
の行がダメみたいですね。
D2DCanvas.RenderTarget.Clear(D2D1ColorF(1.0, 1.0, 1.0, 0.0));
としてもD2DCanvas.RenderTarget.Clear(D2D1ColorF(0.0,0.0,0.0,0.0));と同じ挙動でダメでした。
この部分だけScanLine使うとうまくいきました。(Delphi XE10.2で確認)

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

procedure TForm1.Button1Click(Sender: TObject);
type
  TRGBQArray = array [0..High(Integer) div 4 - 1] of RGBQUAD;
  PRGBQArray = ^TRGBQArray;
const
  //FileName:String = 'C:\Users\xxxx\ドキュメント\test.png';
  FileName:String='a.png';
  Text:String ='文字サンプル';
  w:Integer=500;
  h:Integer=300;
var
  D2DCanvas: TDirect2DCanvas;
  TextFormat: IDWriteTextFormat;
  TextLayout: IDWriteTextLayout;
  Bmp: TBitmap;
  Png: TPngImage;
  p: TD2D1Point2F;
  r: TRect;
  i,ii:Integer;
  PQ: PRGBQArray;
begin
  Bmp := TBitmap.Create;
  Bmp.PixelFormat:=pf32bit;
  Bmp.Transparent := true;
  Bmp.AlphaFormat := afDefined;
  Bmp.SetSize(w,h);
  r := Rect(0,0,w,h);

  {1ピクセルずつアルファチャンネルの値を設定}
  for i := 0 to BMP.Height - 1 do
  begin
    PQ := BMP.ScanLine[i];//RGBQuadの配列へのポインタを代入する
    for ii := 0 to BMP.Width - 1 do
    begin
      TRGBQuad(PQ[ii]).rgbReserved := 0;//アルファチャンネル
      TRGBQuad(PQ[ii]).rgbBlue:=255;
      TRGBQuad(PQ[ii]).rgbGreen:=255;
      TRGBQuad(PQ[ii]).rgbRed:=255;
    end;
  end;

  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;

mam 2023-11-07 10:56:49 No: 151225

すいません、以下のほうが良いのかもです。外していたらすいません。

  {1ピクセルずつアルファチャンネルの値を設定}
  for i := 0 to BMP.Height - 1 do
  begin
    PQ := BMP.ScanLine[i];//RGBQuadの配列へのポインタを代入する
    for ii := 0 to BMP.Width - 1 do
    begin
      TRGBQuad(PQ[ii]).rgbReserved := 0;//アルファチャンネル
      TRGBQuad(PQ[ii]).rgbBlue:=255;
      TRGBQuad(PQ[ii]).rgbGreen:=1;
      TRGBQuad(PQ[ii]).rgbRed:=1;
    end;
  end;

mam 2023-11-07 13:03:50 No: 151229

すいません、アルファチャネルは自力でPNGに入れる必要がありますね。

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

procedure TForm1.Button1Click(Sender: TObject);
type
  TRGBQArray = array [0..High(Integer) div 4 - 1] of RGBQUAD;
  PRGBQArray = ^TRGBQArray;
const
  //FileName:String = 'C:\Users\xxxx\ドキュメント\test.png';
  FileName:String='a.png';
  Text:String ='文字サンプル';
  w:Integer=500;
  h:Integer=300;
var
  D2DCanvas: TDirect2DCanvas;
  TextFormat: IDWriteTextFormat;
  TextLayout: IDWriteTextLayout;
  Bmp: TBitmap;
  Png: TPngImage;
  p: TD2D1Point2F;
  r: TRect;
  y,x:Integer;
  PQ: PRGBQArray;
  AlphaRow: PByteArray;
begin
  Bmp := TBitmap.Create;
  Bmp.PixelFormat:=pf32bit;
  //Bmp.Transparent := true;
  Bmp.AlphaFormat := afDefined;
  Bmp.SetSize(w,h);
  r := Rect(0,0,w,h);

  {1ピクセルずつアルファチャンネルの値を設定}
  for y := 0 to BMP.Height - 1 do
  begin
    PQ := BMP.ScanLine[y];//RGBQuadの配列へのポインタを代入する
    for x := 0 to BMP.Width - 1 do
    begin
      TRGBQuad(PQ[x]).rgbReserved := 0;//アルファチャンネル
      TRGBQuad(PQ[x]).rgbBlue:=255;
      TRGBQuad(PQ[x]).rgbGreen:=0;
      TRGBQuad(PQ[x]).rgbRed:=0;
    end;
  end;

D2DCanvas := TDirect2DCanvas.Create(Bmp.Canvas,r);
D2DCanvas.BeginDraw;

  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.Transparent:=True;
  Png.Assign(Bmp);
  //アルファチャネル情報を追加
  Png.CreateAlpha;
  //アルファチャンネルはPNGに自力で入れる
  for y := 0 to BMP.Height - 1 do
  begin
    PQ := BMP.ScanLine[y];
    AlphaRow:=Png.AlphaScanline[y];
    for x := 0 to BMP.Width - 1 do
    begin
      AlphaRow[x]:=TRGBQuad(PQ[x]).rgbReserved;//アルファチャンネル
    end;
  end;

Png.SaveToFile(FileName);

Png.Free;
Bmp.Free;

end;

AAAAA 2023-11-07 13:14:28 No: 151230

Direct2D いらないよねｗ

soi 2023-11-07 21:19:00 No: 151237

mam様　大変申し訳ありません！実は……先程とあるサイトを参考にすることで目的を果たすことができたのです。すいません、もっと早くこの掲示板を確認しておけばよかったです。対策コーディングを頂きまして本当に感謝いたします。まだ目を通していませんが、高い技術力に圧倒されております。必ず試させていただきます。

私のほうで出た結論をいいますと最初に提示したサンプルコードでDirectWriteはちゃんと機能していました。機能していなかったのはこれです。
Png.Assign(Bmp);
まさにmam様の「アルファチャネルは自力でPNGに入れる必要がある」が正解のようです。

ネットを巡り巡ってたどりついたのがオランダのサイトで、そこに衝撃の一文がありました。
「唯一の問題は PngImage.Assign(Bitmap) を使用して TPngImage にビットマップを割り当てると、アルファチャネルが失われることです」
https://www.bverhue.nl/delphisvg/2016/09/26/save-bitmap-with-transparency-as-png-in-vcl/

……ズッコケました。なんのためのアルファ付きビットマップなのかと。なにはともあれオランダの方が対策コードも載せてくれていたので、ありがたく使用させていただいたところ無事目的を果たすことができました。下記の画像がその結果です。吐き出したPNGを適当な静止画の上にのせたものですが、アンチエイリアス部分がしっかり馴染んでいます。
https://ibb.co/jhcmgBC

本当にお騒がせして申し訳ありませんでした。また、さまざまなご助言をいただきましてありがとうございました。下記私のほうで完成させたコードです。素人コーディングなので間違いがありましたらご指導ください。

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

// アルファ付きBitmapからアルファ付きPNGを生成する（by BVerhue氏）
function PNG4TransparentBitMap(aBitmap: TBitmap): TPNGImage;
const
  CMaxSize = 8000;
type
  TRGB = packed record B, G, R: byte end;
  TRGBA = packed record B, G, R, A: byte end;
  TRGBAArray = array [0..CMaxSize] of TRGBA;
var
  BmpRGBA: ^TRGBAArray;
  PngRGB: ^TRGB;
  X, Y: Integer;
begin
  Result := TPNGImage.CreateBlank(COLOR_RGBALPHA, 8, aBitmap.Width, aBitmap.Height);
  Result.CreateAlpha;
  Result.Canvas.CopyMode := cmSrcCopy;
  Result.Canvas.Draw(0, 0, aBitmap);
  for Y := 0 to Pred(aBitmap.Height) do
  begin
    BmpRGBA := aBitmap.ScanLine[Y];
    PngRGB := Result.ScanLine[Y];
    for X := 0 to Pred(aBitmap.Width) do
    begin
      Result.AlphaScanline[Y][X] := BmpRGBA[X].A;
      if aBitmap.AlphaFormat in [afDefined, afPremultiplied] then
      begin
        if BmpRGBA[X].A <> 0 then
        begin
          // ※引用元が間違っていると思われるので修正しました。
          PngRGB^.B := Round(BmpRGBA[X].B * BmpRGBA[X].A / 255);
          PngRGB^.R := Round(BmpRGBA[X].R * BmpRGBA[X].A / 255);
          PngRGB^.G := Round(BmpRGBA[X].G * BmpRGBA[X].A / 255);
        end
        else
        begin
          PngRGB^.B := Round(BmpRGBA[X].B * 255);
          PngRGB^.R := Round(BmpRGBA[X].R * 255);
          PngRGB^.G := Round(BmpRGBA[X].G * 255);
        end;
      end;
      Inc(PngRGB);
    end;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
const
  CFileName = 'C:\Users\xxx\ドキュメント\Test.png';
  CText = '文字サンプル';
  CWidth = 310;
  CHeight = 80;
var
  D2DCanvas: TDirect2DCanvas;
  TextFormat: IDWriteTextFormat;
  TextLayout: IDWriteTextLayout;
  Bmp: TBitmap;
  Png: TPNGImage;
  pf: TD2D1Point2F;
  r: TRect;
begin
  Bmp := TBitmap.Create;
  Png := nil;
  try
    // アルファ付きBitmapとする
    Bmp.PixelFormat := pf32bit;
    Bmp.AlphaFormat := afDefined;
    Bmp.Transparent := true;
    Bmp.SetSize(CWidth, CHeight);
    // DirectWriteによる文字描画
    r := Rect(0, 0, CWidth, CHeight);
    D2DCanvas := TDirect2DCanvas.Create(Bmp.Canvas, r);
    try
      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, 47, 'ja-jp', TextFormat);
      DWriteFactory.CreateTextLayout(PWideChar(CText), Length(CText), TextFormat, 0,
        0, TextLayout);
      TextLayout.SetWordWrapping(DWRITE_WORD_WRAPPING_NO_WRAP);
      D2DCanvas.Font.Brush.Color := clBlue;
      pf.X := 10;
      pf.Y := 10;
      D2DCanvas.RenderTarget.DrawTextLayout(pf, TextLayout,
        D2DCanvas.Font.Brush.Handle, D2D1_DRAW_TEXT_OPTIONS_NONE);
      D2DCanvas.EndDraw;
    finally
      D2DCanvas.Free;
    end;
    // アルファ付きBitmapからアルファ付きPNGを生成する
    Png := PNG4TransparentBitMap(Bmp);
    Png.SaveToFile(CFileName);
  finally
    Png.Free;
    Bmp.Free;
  end;
end;

AAAAA 2023-11-07 23:49:17 No: 151238

     PngRGB^.B := Round(BmpRGBA[X].B * BmpRGBA[X].A / 255);
     PngRGB^.R := Round(BmpRGBA[X].R * BmpRGBA[X].A / 255);
     PngRGB^.G := Round(BmpRGBA[X].G * BmpRGBA[X].A / 255);

この計算は実際に描画する時の計算で　オブジェクト的なのを作る場合には　RGB に AlphaBlend 加味しちゃダメなんじゃない？

mam 2023-11-08 09:02:45 No: 151239

soi様が示されました
>吐き出したPNGを適当な静止画の上にのせたもの
のurlの画像を拡大して確認しましたら、文字の周りに黒色の縁が有りまして馴染んでないような、、、
お節介ですいません。

AAAAA様の言う通りかもと思います。

soi 2023-11-09 09:02:10 No: 151248

ご指南ありがとうございます。修正しておきます。