StretchBlt APIを使ってハーフトーン設定で画像の縮小コピー～Delphiソースコード集

Delphiの TCanvas には StretchDraw メソッドがありますが、画像を縮小して他の画像にコピーすると線が消えたり点が消えたりすることがあります。
これは StretchDraw メソッドが縮小して画像転送するときに COLORONCOLOR モードを使っている為に発生している可能性があります。
SetStretchBltMode APIで HALFTONE(ハーフトーン)モードに設定し、
StretchBlt APIを使用して画像をコピーすると少し綺麗に画像転送できる可能性があります。

SetStretchBltMode API関数

function SetStretchBltMode(DC: HDC; StretchMode: Integer): Integer; stdcall;

HDC

デバイスコンテキストのハンドルを指定します。
(例) Canvas.Handle

StretchMode

ストレッチモードを指定します。

BLACKONWHITE 又は STRETCH_ANDSCANS	コピー先のピクセルとコピー元のピクセルをAND演算してコピー先のピクセルに設定します。
COLORONCOLOR 又は STRETCH_DELETESCANS	コピー先のピクセルをコピー元のピクセルで置き換えます。
HALFTONE 又は STRETCH_HALFTONE	コピー先のピクセルをコピー元のピクセルの平均値色で置き換えます。
WHITEONBLACK 又は STRETCH_ORSCANS	コピー先のピクセルとコピー元のピクセルをOR演算してコピー先のピクセルに設定します。

戻り値

関数が成功した場合は設定する前のストレッチモード、
失敗した場合は 0 を返す。

StretchBlt API関数

function StretchBlt(
  DestDC: HDC;
  XDest, YDest, DestWidth, DestHeight: Integer; 
  SrcDC: HDC;
  XSrc, YSrc, SrcWidth, SrcHeight: Integer;
  Rop: DWORD
): BOOL; stdcall;

HDC

コピー先デバイスコンテキストのハンドルを指定します

XDest

コピー先の左上のX座標を指定します

YDest

コピー先の左上のY座標を指定します

DestWidth

コピー先の幅を指定します

DestHeight

コピー先の高さを指定します

HDC

コピー元デバイスコンテキストのハンドルを指定します

XSrc

コピー元の左上のX座標を指定します

YSrc

コピー元の左上のY座標を指定します

SrcWidth

コピー元の幅を指定します

SrcHeight

コピー元の高さを指定します

Rop

ラスタオペレーションを指定します。
指定できる主な値は以下

BLACKNESS	コピー先のピクセルを黒色に塗ります。
DSTINVERT	コピー先のピクセルを反転します。
NOTSRCERASE	コピー先のピクセルとコピー元のピクセルをOR演算して反転してコピー先のピクセルに設定します。
SRCAND	コピー先のピクセルとコピー元のピクセルをAND演算してコピー先のピクセルに設定します。
SRCCOPY	コピー元のピクセルをコピー先のピクセルに設定します。
SRCERASE	コピー先のピクセルとコピー元のピクセルをAND演算して反転してコピー先のピクセルに設定します。
SRCINVERT	コピー先のピクセルとコピー元のピクセルをXOR演算してコピー先のピクセルに設定します。
SRCPAINT	コピー先のピクセルとコピー元のピクセルをOR演算してコピー先のピクセルに設定します。
WHITENESS	コピー先のピクセルを白色に塗ります。

試してみる

画面設計とソースコードの記述

Delphi IDEを起動し、[ファイル]⇒[新規作成]⇒[Windows VCL アプリケーション -Delphi]をクリックして新規プロジェクトを作成します。
フォームに、TImage×2個と TButton×2個をドラッグ＆ドロップします。

以下ソースコードをコピー＆ペーストします。

TForm1.OnCreate イベントプロパティに FormCreate を設定します。
Button1.OnClick イベントプロパティに Button1Click を設定します。
Button2.OnClick イベントプロパティに Button2Click を設定します。

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)
    Image1: TImage;
    Image2: TImage;
    Button1: TButton;
    Button2: TButton;
    procedure FormCreate(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    { Private 宣言 }
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
var src,dest:TBitmap;
begin
  src:=Image1.Picture.Bitmap;
  dest:=Image2.Picture.Bitmap;
  dest.Canvas.CopyMode:=cmSrcCopy;
  dest.Canvas.StretchDraw(
    Rect(
      0, 0, dest.Width, dest.Height
    ),
    src
  );
end;

procedure TForm1.Button2Click(Sender: TObject);
var src,dest:TBitmap;
begin
  src:=Image1.Picture.Bitmap;
  dest:=Image2.Picture.Bitmap;
  SetStretchBltMode(dest.Canvas.Handle,HALFTONE);
  StretchBlt(
    dest.Canvas.Handle,
    0, 0, dest.Width, dest.Height,
    src.Canvas.Handle,
    0, 0, src.Width, src.Height,
    SRCCOPY
  );
  Image2.Invalidate;
end;

procedure TForm1.FormCreate(Sender: TObject);
var c:TCanvas;
    w,h:Integer;
    x,y:Integer;
begin
  w:=200;
  h:=200;
  Image1.Width:=w;
  Image1.Height:=h;
  Image1.Picture.Bitmap.SetSize(w,h);

  Image2.Width := w div 2;
  Image2.Height:= h div 2;
  Image2.Picture.Bitmap.SetSize(w div 2,h div 2);

  c:=Image1.Picture.Bitmap.Canvas;
  c.Brush.Color:=$F8FFF8;
  c.FillRect(Rect(0,0,w,h));

  //縦方向に赤い線を引く
  c.Pen.Width:=1;
  c.Pen.Color:=clRed;
  x:=20;
  while x<w do
  begin
    c.MoveTo(x, 0);
    c.LineTo(x, h);
    inc(x,32);
  end;
  //横方向に青い線を引く
  c.Pen.Width:=2;
  c.Pen.Color:=clBlue;
  y:=20;
  while y<h do
  begin
    c.MoveTo(0, y);
    c.LineTo(w, y);
    inc(y,32);
  end;
end;

end.

実行する

実行します。
Button1をクリックすると、Image1 の画像を縦横半分のサイズに縮小して Image2 に表示しますが
画像が綺麗に縮小されているように見えません。

Button2をクリックすると、Image1 の画像を縦横半分のサイズに縮小して Image2 に表示します。
そこそこ綺麗に縮小されています。