Delphiで安全・確実なクリップボード画像処理を実現する

🔰 対象読者

Delphiで画像をクリップボードに送信・受信したい人
Clipboard.Assign や Clipboard.Open による例外や誤動作に悩んでいる人
Delphiのクリップボードを監視していると例外や誤動作に悩んでいる人
TBitmap.Handle, ScanLine, CopyImage の正しい使い方を知りたい人
TBitmap からgif jpeg png形式で保存や読み込みが面倒だなと思っている人

💥 Delphiのクリップボード処理に潜む落とし穴

問題	詳細
`Clipboard.Assign` で例外	COM/OLE由来の遅延描画があると失敗。例外が捕まらないことも
`Clipboard.Open` 時にOSダイアログ	VCL内部で `RaiseLastOSError` → `try..except` では止められない
`bmp.Handle` 使用後に `ScanLine` が破損	GDI化による内部メモリの確定・再構築が原因
一部アプリで貼り付け不可	`CF_BITMAP` のみでは `LINE`, `Photoshop`, `Chrome` などに非対応

💡 解決：4つのユーティリティで万全対応

1. `TClipboardWatcher`

WM_CLIPBOARDUPDATE を安全に監視
グローバル変数で「自分の書き込みは無視」が可能

2. `CopyImageWithMultipleFormats`

CF_BITMAP, CF_DIB, CF_PNG を同時に送信
多くのアプリと互換性あり（Office, Web, AIツール等）

3. `SaveClipboardImageAsPng`

WinAPIベースで画像保存（GlobalAlloc + GetClipboardData）
Clipboard.Open のリトライラップ付き

4. `TBitmapEx`（補助ユニット）

pf32bitを使用した透明pngファイルの取り扱い
LoadFromFile、SaveToFileで拡張子ごとに形式を変えた取り扱い

⚙️ 使用例

bmp := TBitmap.Create;
bmp.Width := 300;
bmp.Height := 100;
bmp.Canvas.Brush.Color := clSkyBlue;
bmp.Canvas.FillRect(Rect(0, 0, bmp.Width, bmp.Height));
CopyImageWithMultipleFormats(bmp);

📌 実装で注意すべきポイント

ScanLine 使用前に bmp.Handle を触らない
Clipboard.Assign で済ませようとしない（例外の原因）
SetClipboardData に渡したハンドルは自動でOSに所有権が移る（解放しない！）

✅ まとめ

VCL標準のクリップボード処理には多くの落とし穴があるので注意
APIベースでのマルチ形式送信＋安定した監視・保存がベスト
本記事のユーティリティ群はそのままプロジェクトに導入可能

🏁 補足情報

動作確認環境：Delphi 10.2 Tokyo / Windows 10
ソースコードはプロジェクト単位で再利用可能
コメント・拡張歓迎！

ソースコード

コードは自由に改変再配布して構いません。
どこかに作者名「VRAMの魔術師」があると少しうれしくなります。

ClipboardEx.pas

unit ClipboardEx;

interface

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


const
  WM_CLIPBOARDUPDATE = $031D;
  CLIPBOARD_DEBOUNCE_MS = 500;

  // クリップボード監視クラス
type
  TClipboardWatcher = class(TPersistent)
  private
    FWindowHandle: HWND;
    FLastTime: TDateTime;
    FOnClipboardChanged: TNotifyEvent;
    procedure WndProc(var Msg: TMessage);
  public
    constructor Create;
    destructor Destroy; override;
    property OnClipboardChanged: TNotifyEvent read FOnClipboardChanged write FOnClipboardChanged;
  end;

// 指定されたファイルの画像をクリップボードにコピー
procedure CopyImageWithMultipleFormats(const FileName: string);
// クリップボードの画像を指定されたファイル名で保存
procedure SaveClipboardImageAsPng(const FileName: string);


implementation

uses
  Vcl.Imaging.pngimage, Vcl.Clipbrd,Winapi.ActiveX;

    // PNG用クリップボード形式登録
var
  CF_PNG: UINT = 0;
  ClipboardUpdateIsSelf : Boolean;


procedure SendImageToClipboardWithFormats(bmp: TBitmapEx);
const
  CF_PNG_NAME = 'PNG';
var
  CF_PNG: UINT;
  tmp: TBitmap;
  hBmp: HBITMAP;
  hDIB, hPNG: HGLOBAL;
  rowSize, dibSize: Integer;
  png: TPngImage;
  stream: TMemoryStream;
  pDIB, pBits, srcLine, dest: PByte;
  ptr: Pointer;
  x, y: Integer;
  bih: BITMAPINFOHEADER;
begin
  if not Assigned(bmp) then Exit;

  CF_PNG := RegisterClipboardFormat(CF_PNG_NAME);

  ClipboardUpdateIsSelf := True;

  // --- スキャンライン安全のため pf32bit でコピー ---
  tmp := TBitmap.Create;
  try
    tmp.PixelFormat := pf32bit;
    tmp.Width := bmp.Width;
    tmp.Height := bmp.Height;
    tmp.Canvas.Draw(0, 0, bmp);  // 描画後 ScanLine 使用可能

    // --- CF_DIB (24bit RGB) 構築 ---
    rowSize := ((tmp.Width * 3 + 3) div 4) * 4;
    dibSize := SizeOf(BITMAPINFOHEADER) + rowSize * tmp.Height;
    hDIB := GlobalAlloc(GMEM_MOVEABLE, dibSize);

    if hDIB <> 0 then
    begin
      pDIB := GlobalLock(hDIB);
      if Assigned(pDIB) then
      begin
        FillChar(bih, SizeOf(bih), 0);
        bih.biSize := SizeOf(bih);
        bih.biWidth := tmp.Width;
        bih.biHeight := tmp.Height;
        bih.biPlanes := 1;
        bih.biBitCount := 24;
        bih.biCompression := BI_RGB;

        Move(bih, pDIB^, SizeOf(bih));
        pBits := pDIB + SizeOf(bih);

        for y := tmp.Height - 1 downto 0 do
        begin
          srcLine := tmp.ScanLine[y];
          dest := pBits;
          for x := 0 to tmp.Width - 1 do
          begin
            dest^ := srcLine^;      Inc(dest); Inc(srcLine); // B
            dest^ := srcLine^;      Inc(dest); Inc(srcLine); // G
            dest^ := srcLine^;      Inc(dest); Inc(srcLine); // R
            Inc(srcLine); // Skip A
          end;
          Inc(pBits, rowSize);
        end;

        GlobalUnlock(hDIB);
      end;
    end;

    // --- CF_PNG 構築 ---
    stream := TMemoryStream.Create;
    png := TPngImage.Create;
    try
      png.Assign(tmp);
      png.SaveToStream(stream);
      stream.Position := 0;

      hPNG := GlobalAlloc(GMEM_MOVEABLE, stream.Size);
      if hPNG <> 0 then
      begin
        ptr := GlobalLock(hPNG);
        if Assigned(ptr) then
        begin
          Move(stream.Memory^, ptr^, stream.Size);
          GlobalUnlock(hPNG);
        end;
      end;
    finally
      png.Free;
      stream.Free;
    end;

    // --- 最後に CF_BITMAP を作成（破壊されないように最後！） ---
    hBmp := CopyImage(tmp.Handle, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG or LR_COPYDELETEORG);

    // --- クリップボードに登録 ---
    if OpenClipboard(0) then
    try
      EmptyClipboard;
      if hBmp <> 0 then SetClipboardData(CF_BITMAP, hBmp);
      if hDIB <> 0 then SetClipboardData(CF_DIB, hDIB);
      if hPNG <> 0 then SetClipboardData(CF_PNG, hPNG);
    finally
      CloseClipboard;
    end;

  finally
    tmp.Free;
  end;
end;

procedure CopyImageWithMultipleFormats(const FileName: string);
var
  png: TPngImage;
  bmp: TBitmapEx;
begin
  png := TPngImage.Create;
  bmp := TBitmapEx.Create;
  try
    if not FileExists(FileName) then exit;
    bmp.LoadFromFile(FileName);
    SendImageToClipboardWithFormats(bmp);
  finally
    png.Free;
    bmp.Free;
  end;
end;


function SafeOpenClipboard(hWnd: HWND = 0; Retry: Integer = 10; DelayMS: Integer = 50): Boolean;
var
  i: Integer;
begin
  for i := 1 to Retry do
  begin
    if OpenClipboard(hWnd) then
      Exit(True);
    Sleep(DelayMS);
  end;
  Result := False;
end;

procedure SaveClipboardImageAsPng(const FileName: string);
var
  hBmp: HBITMAP;
  bmp: TBitmap;
  png: TPngImage;
begin
  if not SafeOpenClipboard(0) then Exit;

  try
    if not IsClipboardFormatAvailable(CF_BITMAP) then Exit;

    hBmp := GetClipboardData(CF_BITMAP);
    if hBmp = 0 then Exit;

    hBmp := CopyImage(hBmp, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG or LR_COPYDELETEORG);
    if hBmp = 0 then Exit;

    bmp := TBitmap.Create;
    png := TPngImage.Create;
    try
      bmp.Handle := hBmp;
      png.Assign(bmp);
      png.SaveToFile(FileName);
    finally
      png.Free;
      bmp.Free;
    end;

  finally
    CloseClipboard;
  end;
end;

constructor TClipboardWatcher.Create;
begin
  inherited;
  FLastTime := 0;
  FWindowHandle := AllocateHWnd(WndProc);
  AddClipboardFormatListener(FWindowHandle);
end;

destructor TClipboardWatcher.Destroy;
begin
  RemoveClipboardFormatListener(FWindowHandle);
  DeallocateHWnd(FWindowHandle);
  inherited;
end;

procedure TClipboardWatcher.WndProc(var Msg: TMessage);
begin
  if Msg.Msg = WM_CLIPBOARDUPDATE then
  begin
    if MilliSecondsBetween(Now, FLastTime) >= CLIPBOARD_DEBOUNCE_MS then
    begin
      FLastTime := Now;
      if not ClipboardUpdateIsSelf then
      if Assigned(FOnClipboardChanged) then
        FOnClipboardChanged(Self);
      ClipboardUpdateIsSelf := False;
    end;
  end;

  Msg.Result := DefWindowProc(FWindowHandle, Msg.Msg, Msg.WParam, Msg.LParam);
end;

end.

BitmapEx.pas

unit BitmapEx;

// ファイルを読み込んでビットマップで返す
// PNG GIFの透過を処理
interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, ExtCtrls,Vcl.ComCtrls,PNGImage,Jpeg;

type  TFourth = packed record
    B,G,R,A : Byte;
  end;
TFourthArray = array[0..40000000] of TFourth;
PFourthArray = ^TFourthArray;

type TBitmapExStretch = (bsNormal,        // 標準
                         bsLockHeight,    // 高さ固定
                         bsLockWidth      // 幅固定
                         );

type TBitmapExFileExt = ( bfNil,
                          bfBmp,
                          bfGif,
                          bfJpg,
                          bfPng
                          );

type
  TBitmapEx = class(TBitmap)
  private
    { Private 宣言 }
    FBackgroundColor: TColor;
    FTransparentColor: TColor;
    FTransparencyMode: TPNGTransparencyMode;
    FTransparent: Boolean;

    // 拡張子から画像形式を判断
    function CheckFileExt(const FileName : string) : TBitmapExFileExt;

    // GIF ファイル読み込み
    procedure LoadFromFileGif(const Filename: string);
    // Jpeg ファイル読み込み
    procedure LoadFromFileJpg(const Filename: string);
    // PNG ファイル読み込み
    procedure LoadFromFilePng(const Filename: string);

    // GIF ファイル書き込み
    procedure SaveToFileGif(const Filename: string);
    // Jpeg ファイル書き込み
    procedure SaveToFileJpg(const Filename: string);
    // PNG ファイル書き込み
    procedure SaveToFilePng(const Filename: string);


  public
    { Public 宣言 }
    constructor Create();override;
    procedure Clear();

    procedure AssignJpeg(jpeg : TJPEGImage);
    procedure AssignTransparent(Source : TBitmapEx);
    // ファイルを読み込み
    procedure LoadFromFile(const Filename: string); override;
    // ファイルを読み込み
    procedure SaveToFile(const Filename: string); override;
    // 指定されたビットマップをアスペクト比を維持して指定されたサイズ以内で描画
    procedure StretchDraw(const aWidth,aHeight : Integer;bmp : TBitmap);
    // 指定されたビットマップをアスペクト比を維持して指定されたサイズで中央に描画
    procedure CenterDraw(const aWidth,aHeight : Integer;bmp : TBitmap);

    // 反転して描画 0:反転無し 1: 左右反転、2:上下反転 3:上下左右反転
    procedure DrawInvert(bmp : TBitmap;Mode : Integer=0);

    // 背景色に使用する色
    property BackgroundColor : TColor read FBackgroundColor write FBackgroundColor;

    property Transparent : Boolean read FTransparent write FTransparent;
    property TransparentColor : TColor read FTransparentColor write FTransparentColor;
    property TransparencyMode : TPNGTransparencyMode read FTransparencyMode write FTransparencyMode;
  end;


implementation

uses GIFImg;

{ TBitmapEx }

constructor TBitmapEx.Create;
begin
  inherited;
  FBackgroundColor := clWhite;
end;

procedure TBitmapEx.DrawInvert(bmp: TBitmap; Mode: Integer=0);
  function GetX(const x,xh,mode : Integer) : Integer;
  begin
    result := x;
    if (mode = 1) or (mode = 3) then result := xh - x - 1;
  end;
  function GetY(const y,yh,mode : Integer) : Integer;
  begin
    result := y;
    if (mode = 2) or (mode = 3) then result := yh - y - 1;
  end;
var
  x1,y1,x2,y2 : Integer;
  slFrom,slTo : array of Pointer;
begin
  SetSize(bmp.Width,bmp.Height);
  SetLength(slFrom,Height);
  SetLength(slTo,Height);
  for y1 := 0 to Height-1 do begin
    slFrom[y1] := bmp.ScanLine[y1];
    slTo[y1]   := ScanLine[y1];
  end;
  for y1 := 0 to Height-1 do begin                // 高さ分ループ
    for x1 := 0 to Width-1 do begin               // 横幅分ループ
      x2 := GetX(x1,Width,Mode);
      y2 := GetY(y1,Height,Mode);
      PFourthArray(slTo[y2])^[x2].R := PFourthArray(slFrom[y1])^[x1].R;
      PFourthArray(slTo[y2])^[x2].G := PFourthArray(slFrom[y1])^[x1].G;
      PFourthArray(slTo[y2])^[x2].B := PFourthArray(slFrom[y1])^[x1].B;
      PFourthArray(slTo[y2])^[x2].A := PFourthArray(slFrom[y1])^[x1].A;
    end;
  end;
end;

procedure TBitmapEx.Clear;
var
  x,y : Integer;
  Lines : array of Pointer;
begin
  SetLength(Lines,Height);
  for y := 0 to Height-1 do begin
    Lines[y] := ScanLine[y];
  end;
  for y := 0 to Height-1 do begin                // 高さ分ループ
    for x := 0 to Width-1 do begin               // 横幅分ループ

      PFourthArray(Lines[y])^[x].R := 0; // 描画先RGB画素データを取得
      PFourthArray(Lines[y])^[x].G := 0;
      PFourthArray(Lines[y])^[x].B := 0;
      PFourthArray(Lines[y])^[x].A := 0;  // αチャンネルは手動処理のためないものとする
    end;
  end;
  AlphaFormat := afDefined;
{
  Canvas.Brush.Style := bsSolid;
  Canvas.Brush.Color := FBackgroundColor;
  Canvas.FillRect(Canvas.ClipRect);
  }
end;

procedure TBitmapEx.LoadFromFile(const Filename: string);
begin
  if not FileExists(Filename) then exit;
  case CheckFileExt(Filename) of
    bfBmp : inherited LoadFromFile(Filename);
    bfGif : LoadFromFileGif(Filename);
    bfJpg : LoadFromFileJpg(Filename);
    bfPng : LoadFromFilePng(Filename);
  end;
end;

procedure TBitmapEx.LoadFromFileGif(const Filename: string);
var
  gif : TGIFImage;
begin
  gif := TGIFImage.Create;
  try
    gif.LoadFromFile(Filename);
    Assign(gif);
  finally
    gif.Free;
  end;
end;

procedure TBitmapEx.LoadFromFileJpg(const Filename: string);
var
  jpg : TJPEGImage;
begin
  jpg := TJPEGImage.Create;
  try
    jpg.LoadFromFile(Filename);
    Assign(jpg);
  finally
    jpg.Free;
  end;
end;

procedure TBitmapEx.LoadFromFilePng(const Filename: string);
var
  png : TPngImage;
begin
  png := TPngImage.Create;
  try
    png.LoadFromFile(Filename);
    FTransparentColor := png.TransparentColor;
    FTransparencyMode := png.TransparencyMode;
    FTransparent := png.Transparent;
    Assign(png);
  finally
    png.Free;
  end;
end;


function TBitmapEx.CheckFileExt(const FileName: string): TBitmapExFileExt;
var
  s : string;
begin
  result := bfNil;
  s := ExtractFileExt(FileName);
  if Copy(s,1,1) <> '.' then exit;
  s := Copy(s,2,Length(s));
  if CompareText(s,'bmp')  = 0 then result := bfBmp;
  if CompareText(s,'gif')  = 0 then result := bfGif;
  if CompareText(s,'jpg')  = 0 then result := bfJpg;
  if CompareText(s,'jpeg') = 0 then result := bfJpg;
  if CompareText(s,'png')  = 0 then result := bfPng;

end;


procedure TBitmapEx.SaveToFile(const Filename: string);
begin
  case CheckFileExt(Filename) of
    bfBmp : inherited SaveToFile(Filename);
    bfGif : SaveToFileGif(Filename);
    bfJpg : SaveToFileJpg(Filename);
    bfPng : SaveToFilePng(Filename);
  end;
end;

procedure TBitmapEx.SaveToFileGif(const Filename: string);
var
  gif : TGIFImage;
begin
  gif := TGIFImage.Create;
  try
    gif.Assign(Self);
    gif.SaveToFile(Filename);
  finally
    gif.Free;
  end;
end;

procedure TBitmapEx.SaveToFileJpg(const Filename: string);
var
  jpg : TJPEGImage;
begin
  jpg := TJPEGImage.Create;
  try
    jpg.Assign(Self);
    jpg.SaveToFile(Filename);
  finally
    jpg.Free;
  end;
end;

procedure TBitmapEx.SaveToFilePng(const Filename: string);
type
  TRGBQArray = array [0..High(Integer) div 4 - 1] of RGBQUAD;
  PRGBQArray = ^TRGBQArray;
  TRGBTArray = array [0..High(Integer) div 3 - 1] of RGBTRIPLE;
  PRGBTArray = ^TRGBTArray;
var
  PNG: TPngImage;
  i,ii: Integer;
  BPQ: PRGBQArray;
  CQ: RGBQUAD;
  PPT: PRGBTArray;
  CT: RGBTRIPLE;
begin
  PNG := TPngImage.CreateBlank(COLOR_RGBALPHA,8,Self.Width,Self.Height);
  try
    for i := 0 to Self.Height - 1 do
    begin
      BPQ := Self.ScanLine[i];
      PPT := PNG.ScanLine[i];
      for ii := 0 to Self.Width - 1 do
      begin
        CQ := BPQ[ii];
        CT.rgbtBlue := CQ.rgbBlue;
        CT.rgbtGreen := CQ.rgbGreen;
        CT.rgbtRed := CQ.rgbRed;
        PPT[ii] := CT;
        PNG.AlphaScanline[i]^[ii] := CQ.rgbReserved;
      end;
    end;

    PNG.SaveToFile(Filename);
  finally
    PNG.Free;
  end;
{
var
  png : TPngImage;
begin
  png := TPngImage.Create;
  try
    png.Assign(Self);
    //png.Transparent := FTransparent;
    //png.TransparencyMode := FTransparentMode;
    //if FTransparent then png.TransparentColor := FTransparentColor;
    png.SaveToFile(Filename);
  finally
    png.Free;
  end;
  }
end;

// アスペクトル比を合わせた範囲を取得 r : 変形先としての範囲 aWidth,aHeight:元画像ファイル
procedure RectToStreachRect(var r : TRect;const aWidth,aHeight : Integer);
//var
//  xh,yh : Integer;
begin
  if aWidth = 0 then exit;
  if aHeight = 0 then exit;
  if r.Width > aWidth then begin
    r.Height := r.Height * aWidth div r.Width;
    r.Width := aWidth;
  end;
  if r.Height > aHeight then begin
    r.Width := r.Width * aHeight div r.Height;
    r.Height := aHeight;
  end;

  {
  if aWidth > aHeight then begin
    yh := r.Width * aHeight div aWidth;
    r.Height := yh;
  end
  else begin
    xh := r.Height * aWidth div aHeight;
    r.Width := xh;
  end;
  }
end;

procedure RectToCenterRect(var r : TRect;const aWidth,aHeight : Integer);
var
  xh,yh,xhr,yhr : Integer;
begin
  if aWidth = 0 then exit;
  if aHeight = 0 then exit;

  xhr := r.Width;
  yhr := r.Height;
  if aWidth > aHeight then begin
    yh := r.Width * aHeight div aWidth;
    r.Top := (yhr - yh) div 2;
    r.Height := yh;
  end
  else begin
    xh := r.Height * aWidth div aHeight;
    r.Left := (xhr - xh) div 2;
    r.Width := xh;
  end;
end;

procedure TBitmapEx.StretchDraw(const aWidth, aHeight: Integer; bmp: TBitmap);
var
  r : TRect;
begin
  r := Rect(0,0,bmp.Width,bmp.Height);
  RectToStreachRect(r,aWidth,aHeight);
  SetSize(r.Width,r.Height);
  Clear;
  Canvas.StretchDraw(r,bmp);
end;

procedure TBitmapEx.AssignJpeg(jpeg: TJPEGImage);
var
  bmp :TBitmapEx;
begin
  bmp := TBitmapEx.Create;
  try
    bmp.Assign(jpeg);
    DrawInvert(bmp);
  finally
    bmp.Free;
  end;
end;

procedure TBitmapEx.AssignTransparent(Source: TBitmapEx);
begin
  FTransparent := Source.FTransparent;
  FTransparentColor := Source.FTransparentColor;
  FTransparencyMode := Source.FTransparencyMode;
end;

procedure TBitmapEx.CenterDraw(const aWidth, aHeight: Integer; bmp: TBitmap);
var
  r : TRect;
begin
  r := Rect(0,0,aWidth,aHeight);
  RectToCenterRect(r,bmp.Width,bmp.Height);
  SetSize(aWidth,aHeight);
  Clear;
  Canvas.StretchDraw(r,bmp);
end;
end.