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

var
  Form1: TForm1;

implementation

uses
  Winapi.MMSystem;

{$R *.dfm}

//=============================================================================
//  マウスカーソ画像をキャプチャ
//
//  マウスカーソルのハンドルを取得
//  そのハンドルを使用して DrawIconEx でマウスカーソルの画像を取得
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  LtartTime   : DWORD;
  LCursorPos  : TPoint;
  LCursorInfo : TCursorInfo;
begin
  //指定時間が経過したらキャプチャ
  LtartTime := timeGetTime;
  while (timeGetTime - LtartTime) < 5000 do begin
    Sleep(100);
    Application.ProcessMessages;
  end;


  //カーソルの位置を取得
  GetCursorPos(LCursorPos);

  // 現在のスクリーンに表示中のマウスカーソルの情報を取得
  LCursorInfo.cbSize := SizeOf(TCursorInfo);
  LCursorInfo.flags  := CURSOR_SHOWING;
  GetCursorInfo(LCursorInfo);

  // その情報を元に，Image1に描画する
  Image1.Picture.Assign(nil);
  DrawIconEx(Image1.Canvas.Handle, 0, 0, LCursorInfo.hCursor,
             0, 0, 0, 0, DI_DEFAULTSIZE or DI_NORMAL);

  // 解放・破棄の処理
  DestroyCursor(LCursorInfo.hCursor);
end;   

end.

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

var
  Form1: TForm1;

implementation

uses
  Winapi.MMSystem;

{$R *.dfm}

//=============================================================================
//  マウスカーソ画像をキャプチャ
//
//  マウスカーソルのハンドルを取得
//  そのハンドルを使用して DrawIconEx でマウスカーソルの画像を取得
//
//  (1) DrawIconEx で取得画像サイズを指定する
//  (2) DI_DEFAULTSIZE フラグを使用しないで DI_IMAGE だけを指定する
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
 var
  LtartTime   : DWORD;
  LBitmap     : TBitmap;
  LCursorPos  : TPoint;
  LCursorInfo : TCursorInfo;
  LIconInfo   : TIconInfo;
  LImgSize    : Integer;
  LText       : string;
begin
  //指定時間が経過したらキャプチャ
  LtartTime := timeGetTime;
  while (timeGetTime - LtartTime) < 5000 do begin
    Sleep(100);
    Application.ProcessMessages;
  end;


  //カーソルの位置を取得
  GetCursorPos(LCursorPos);

  // 現在のスクリーンに表示中のマウスカーソルの情報を取得
  LCursorInfo.cbSize := SizeOf(TCursorInfo);
  LCursorInfo.flags  := CURSOR_SHOWING;
  GetCursorInfo(LCursorInfo);

  // 画像のサイズを指定
  LImgSize := 144;

  LBitmap := TBitmap.Create;
  try
    LBitmap.SetSize(LImgSize, LImgSize);

    DrawIconEx(LBitmap.Canvas.Handle, 0, 0, LCursorInfo.hCursor,
               LImgSize, LImgSize, 0, 0, DI_IMAGE);

    // Windows 10 のマウスカーソルはアルファチャンネルを使用した 32 bit の画像
    // したがって，以下の設定が必要
    LBitmap.PixelFormat := pf32bit;
    LBitmap.AlphaFormat := afDefined;

    Image1.Picture.Assign(nil);
    // 透過状態を確認するために 背景の TImage を塗り潰す
    Image1.Canvas.Brush.Color := clSilver;
    Image1.Canvas.FillRect(LBitmap.Canvas.ClipRect);

    // TBitmap を TImage に描画
    Image1.Canvas.Draw(0, 0, LBitmap);
  finally
    FreeAndNil(LBitmap);
  end;


  // アイコン画像としての情報を取得してホットスポットの値を表示
  GetIconInfo(LCursorInfo.hCursor, LIconInfo);
  LText := 'xHotspot : ' + IntToStr(LIconInfo.xHotspot) + sLineBreak
         + 'yHotspot : ' + IntToStr(LIconInfo.yHotspot);

  MessageBox(Handle, PChar(LText), 'Hotspot', MB_ICONINFORMATION);

  // 解放・破棄の処理
  DeleteObject(LIconInfo.hbmMask);
  DeleteObject(LIconInfo.hbmMask);
  DestroyCursor(LCursorInfo.hCursor);
end;

end.

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

  function GetMouseCursorSize: Integer;

var
  Form1: TForm1;

implementation

uses
  System.Win.Registry;

{$R *.dfm}
//=============================================================================
//  マウスカーソルのサイズを取得
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  LSize : Integer;
  LText : string;
begin
  LSize := GetMouseCursorSize;

  LText := 'マウスカーソルのサイズ' + sLineBreak + IntToStr(LSize);
  MessageBox(Handle, PChar(LText), '情報', MB_ICONINFORMATION);
end;

//-----------------------------------------------------------------------------
//  現在のマウスカーソルのサイズを取得する関数
//-----------------------------------------------------------------------------
function GetMouseCursorSize: Integer;
var
  LRegistry : TRegistry;
  LKeyName  : string;
begin
  Result := 0;

  LRegistry := TRegistry.Create;
  try
    LRegistry.Access  := KEY_READ;
    LRegistry.RootKey := HKEY_CURRENT_USER;
    LKeyName :='Control Panel\Cursors';

    if LRegistry.OpenKey(LKeyName, False) then begin
      Result := LRegistry.ReadInteger('CursorBaseSize');
      LRegistry.CloseKey;
    end;
  finally
    FreeAndNil(LRegistry);
  end;
end;

end.

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)
    Button1: TButton;
    ListBox1: TListBox;
    procedure Button1Click(Sender: TObject);
  private
    { Private 宣言 }
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

//=============================================================================
//  Delphi のマウスカーソル TCursor 型の値を列挙
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  LName  : string;
  LIndex : Integer;
begin
  ListBox1.Items.Clear;
  ListBox1.Items.BeginUpdate;
  for LIndex := -1 downto -22 do begin
    LName := CursorToString(TCursor(LIndex));
    if StrToIntDef(LName, 0) = 0 then begin
      ListBox1.Items.Add(LName);
    end;
  end;
  ListBox1.Items.EndUpdate;
end;

end.

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)
    Button1: TButton;
    ListBox1: TListBox;
    procedure Button1Click(Sender: TObject);
  private
    { Private 宣言 }
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses
  System.Win.Registry;

{$R *.dfm}

//=============================================================================
//  Windows 10 のマウスカーソル名を列挙
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  LRegistry : TRegistry;
  LKeyName  : string;
  LItemList : TStringList;
  LItemType : TRegDataType;
  LIndex    : Integer;
begin
  LRegistry := TRegistry.Create;
  LItemList := TStringList.Create;
  try
    LRegistry.Access  := KEY_READ;
    LRegistry.RootKey := HKEY_CURRENT_USER;
    LKeyName :='Control Panel\Cursors';

    // キー内の項目のリストを取得
    LRegistry.OpenKey(LKeyName, False);
    LRegistry.GetValueNames(LItemList);

    // REG_EXPAND_SZ 型 (可変長の文字列型) の値だけを列挙
    ListBox1.Items.Clear;
    ListBox1.Items.BeginUpdate;
    for LIndex := 0 to LItemList.Count - 1 do begin
      if LItemList[LIndex] = '' then Continue;

      LItemType := LRegistry.GetDataType(LItemlist[LIndex]);
      if LItemType = rdExpandString then begin
        ListBox1.Items.Add(LItemList[LIndex]);
      end;
    end;
    ListBox1.Items.EndUpdate;

    LRegistry.CloseKey;
  finally
    FreeAndNil(LRegistry);
    FreeAndNil(LItemList);
  end;
end;

end.

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)
    Button1: TButton;
    Edit1: TEdit;
    procedure Button1Click(Sender: TObject);
  private
    { Private 宣言 }
  public
    { Public 宣言 }
  end;

  function GetShowCursorHandle: HCURSOR;
  function GetCursorFilePath: string;
  function GetMouseCursorFilePath(CursorID: TCursor): string;

var
  Form1: TForm1;

implementation

uses
  System.Win.Registry,
  Winapi.MMSystem;

{$R *.dfm}

//=============================================================================
//  スクリーンに表示中のマウスカーソルのカーソルファイルのフルパスを取得
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  LStartTime : DWORD;
  LFilePath  : string;
begin
  Edit1.Text := '';

  // 指定時間が経過したらキャプチャ
  LStartTime := timeGetTime;
  while (timeGetTime - LStartTime) < 5000 do begin
    Sleep(10);
    Application.ProcessMessages;
  end;

  LFilePath := GetCursorFilePath;
  Edit1.Text := LFilePath;
  Edit1.SelStart := Length(Edit1.Text);
end;

//-----------------------------------------------------------------------------
//  現在スクリーンに表示れているマウスカーソルのハンドルを取得する関数
//-----------------------------------------------------------------------------
function GetShowCursorHandle: HCURSOR;
var
  LCursorInfo : TCursorInfo;
begin
  LCursorInfo.cbSize := SizeOf(TCursorInfo);
  LCursorInfo.flags  := CURSOR_SHOWING;
  GetCursorInfo(LCursorInfo);
  Result := LCursorInfo.hCursor;
end;

//-----------------------------------------------------------------------------
//  マウスカーソルのファイルのフルパスを取得する関数
//
//  (1) マウスカーソルのハンドルを取得
//  (2) そのハンドルに相当する TCursor 型の値を調べる
//  (3) TCuror 型に該当する Windows 10 のマウスカーソル名を調べる
//  (4) そのマウスカーソル名のフルパスを取得
//-----------------------------------------------------------------------------
function GetCursorFilePath: string;
var
  LhCursor  : HCURSOR;
  LCursorID : TCursor;
  LFilePath : string;
  LIndex    : Integer;
begin
  LFilePath := '';
  LhCursor := GetShowCursorHandle;

  // カーソルのハンドルから TCursor の値を取得
  LCursorID := 0;
  for LIndex := -1 downto -22 do begin
    if LhCursor = Screen.Cursors[LIndex] then begin
      LCursorID := TCursor(LIndex);
      Break;
    end;
  end;

  // TCursor の値に相当するカーソルファイルがあるか調べる
  if LCursorID <> 0 then begin
    Result := GetMouseCursorFilePath(LCursorID);
  end;

  if LhCursor <> 0 then DestroyCursor(LhCursor);
end;
//-----------------------------------------------------------------------------
//  環境変数を含む文字列から実際のフルパスを取得する関数
//-----------------------------------------------------------------------------
function ExpandEnvironmentString(S: string): string;
var
  LDstChar : array [0..MAX_PATH-1] of Char;
begin
  ExpandEnvironmentStrings(PChar(S), LDstChar, MAX_PATH);
  Result := LDstChar;
end;

//-----------------------------------------------------------------------------
//  Delphi の TCursor 型の値からからカーソルファイルのフルパスを取得
//  Windows にないカーソルの時は空文字を返す
//-----------------------------------------------------------------------------
function GetMouseCursorFilePath(CursorID: TCursor): string;
var
  LRegistry : TRegistry;
  LItemName : string;
  LKeyName  : string;
begin
  Result := '';

  case CursorID of
    crArrow     : LItemName := 'Arrow';
    crCross     : LItemName := 'Crosshair';
    crIBeam     : LItemName := 'IBeam';
    crSizeNESW  : LItemName := 'SizeNESW';
    crSizeNS    : LItemName := 'SizeNS';
    crSizeNWSE  : LItemName := 'SizeNWSE';
    crSizeWE    : LItemName := 'SizeWE';
    crUpArrow   : LItemName := 'UpArrow';
    crHourGlass : LItemName := 'Wait';
    crDrag      : LItemName := '';
    crNoDrop    : LItemName := '';
    crHSplit    : LItemName := '';
    crVSplit    : LItemName := '';
    crMultiDrag : LItemName := '';
    crSQLWait   : LitemName := '';
    crNo        : LItemName := 'No';
    crAppStart  : LItemName := 'Appstarting';
    crHelp      : LItemName := 'Help';
    crHandPoint : LItemName := 'Hand';
    crSizeAll   : LItemName := 'SizeAll';
  else
    LItemName := '';
  end;
  if LItemName = '' then Exit;

  LRegistry := TRegistry.Create;
  try
    LRegistry.Access  := KEY_READ;
    LRegistry.RootKey := HKEY_CURRENT_USER;
    LKeyName :='Control Panel\Cursors';

    if LRegistry.OpenKey(LKeyName, False) then begin
     Result := LRegistry.ReadString(LItemName);
      // 環境変数が含まれている場合があるので実パスに変換
      Result := ExpandEnvironmentString(Result);

      LRegistry.CloseKey;
    end;
  finally
    FreeAndNil(LRegistry);
  end;
end;

end.

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

  function GetMouseCursorSize: Integer;
  function ExpandEnvironmentString(S: string): string;

var
  Form1: TForm1;

implementation

uses
  System.Win.Registry;

{$R *.dfm}

//=============================================================================
//  カーソルファイルを読み込んでマウスカーソ画像を表示
//
//  TIcon.LoadFromFile は使用できない
//  Windows のマウスカーソルファイルはマルチカーソル (マルチアイコン) ファイル
//  TIcon はマルチアイコンに対応していない
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  LImgSize    : Integer;
  LDeffSize   : Integer;
  LImagPath   : string;
  LBitmap     : TBitmap;
  LhCursor    : HCURSOR;
begin
  LImgSize  := GetMouseCursorSize;
  LDeffSize := GetSystemMetrics(SM_CXCURSOR);

  LImagPath := '%SYSTEMROOT%\Cursors\aero_busy.ani';
  LImagPath := ExpandEnvironmentString(LImagPath);

  LBitmap := TBitmap.Create;
  try
    LBitmap.SetSize(LImgSize, LImgSize);

    // ファイルからカーソルファイルを読み込んでカーソルのハンドルを取得
    if LImgSize = LDeffSize then begin
      LhCursor := LoadImage(HInstance, PChar(LImagPath), IMAGE_CURSOR,
                            0, 0, LR_DEFAULTSIZE);
    end else begin
      LhCursor := LoadImage(HInstance, PChar(LImagPath), IMAGE_CURSOR,
                            0, 0, LR_LOADFROMFILE);
    end;

    //マウスカーソル画像を TBitmap の Canvas に描画
    DrawIconEx(LBitmap.Canvas.Handle, 0, 0, LhCursor,
               LImgSize, LImgSize, 0, 0, DI_IMAGE);

    // Windows 10 のマウスカーソルはアルファチャンネル付きの 32 bit のビットマップ
    // DrawIconEx の後で設定する
    LBitmap.PixelFormat := pf32bit;
    LBitmap.AlphaFormat := afDefined;

    // TImage に TBitmap を描画
    Image1.Canvas.Draw(0, 0, LBitmap);
  finally
    FreeAndNil(LBitmap);
  end;
end;

//-----------------------------------------------------------------------------
//  現在のマウスカーソルのサイズを取得する関数
//-----------------------------------------------------------------------------
function GetMouseCursorSize: Integer;
var
  LRegistry : TRegistry;
  LKeyName  : string;
begin
  LRegistry := TRegistry.Create;
  try
    LRegistry.Access  := KEY_READ;
    LRegistry.RootKey := HKEY_CURRENT_USER;
    LKeyName :='Control Panel\Cursors';

    LRegistry.OpenKey(LKeyName, False);
    Result := LRegistry.ReadInteger('CursorBaseSize');

    LRegistry.CloseKey;
  finally
    FreeAndNil(LRegistry);
  end;
end;

//-----------------------------------------------------------------------------
//  環境変数を含む文字列から実際のフルパスを取得する関数
//-----------------------------------------------------------------------------
function ExpandEnvironmentString(S: string): string;
var
  LDstChar : array [0..MAX_PATH-1] of Char;
begin
  ExpandEnvironmentStrings(PChar(S), LDstChar, MAX_PATH);
  Result := LDstChar;
end;

end.

  // マウスカーソル画像のサイズを取得
  // 戻り値が画像のサイズ
  function GetMouseCursorSize: Integer;

  // マウスカールの画像を 32 bit のアルファチャンネル付きのビットマップとして取得
  // 戻り値はホットスポットの値
  function GetMouseCursorBitmap(ABitmap: TBitmap;
    ADropShadow: Boolean = False): TPoint; overload;
  function GetMouseCursorBitmap(CursorID: TCursor; ABitmap: TBitmap;
    ADropShadow: Boolean = False): TPoint; overload;

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)
    Button1: TButton;
    ListBox1: TListBox;
    Panel1: TPanel;
    Image1: TImage;
    procedure Button1Click(Sender: TObject);
    procedure ListBox1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    { Private 宣言 }
    procedure DrawCursorImage(ACursor: TCursor);
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses
  plMouseCursorImage,
  Winapi.MMSystem;

{$R *.dfm}

//=============================================================================
//  マウスカーソル画像取得用ユニット plMouseCursorImage のテストプログラム
//
//  フォーム生成時の処理
//  Delphi の TCursor 型の名前のリストを作成して TListBox に表示
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
var
  LName  : string;
  LIndex : Integer;
begin
  ListBox1.Items.Clear;
  ListBox1.Items.BeginUpdate;
  for LIndex := -1 downto -22 do begin
    LName := CursorToString(TCursor(LIndex));
    if StrToIntDef(LName, 0) = 0 then begin
      ListBox1.Items.Add(LName);
    end;
  end;
  ListBox1.Items.EndUpdate;
end;

//=============================================================================
//  指定時間経過したら，スクリーン上のマウスカーソル画像をキャプチャ
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  LStartTime  : DWORD;
begin
  // 指定時間が経過したらキャプチャ開始
  LStartTime := timeGetTime;
  while (timeGetTime - LStartTime) < 5000 do begin
    Sleep(10);
    Application.ProcessMessages;
  end;

  ListBox1.ItemIndex := -1;
  DrawCursorImage(0);
end;

//=============================================================================
//  TListBox でカーソル名を選択したら，そのマウスカーソル画像を TImage に描画
//=============================================================================
procedure TForm1.ListBox1Click(Sender: TObject);
var
  Lindex  : Integer;
  LCursor : TCursor;
begin
  Lindex := ListBox1.ItemIndex;
  if Lindex < 0 then Exit;

  LCursor := 0;
  for LIndex := -1 downto -22 do begin
    if LIndex = StringToCursor(ListBox1.Items[ListBox1.ItemIndex]) then begin
      LCursor := Lindex;
      Break;
    end;
  end;

  DrawCursorImage(LCursor);
end;

//-----------------------------------------------------------------------------
//  引数の TCursor 型に該当するマウスカーソル画像を TImage に描画するメソッド
//  ACursor が 0 の時は現在スクリーンに表示中のマウスカーソル画像
//-----------------------------------------------------------------------------
procedure TForm1.DrawCursorImage(ACursor: TCursor);
var
  LBitmap     : TBitmap;
  LImgSize  : Integer;
  LHotspot  : TPoint;
  LText     : string;
begin
  Image1.Picture.Assign(nil);

  LBitmap := TBitmap.Create;
  try
    // マウスカーソル画像のサイズを取得
    LImgSize := GetMouseCursorSize;
    if LImgSize = 0 then Exit;

    // マウスカーソルの画像をビットマップ画像として取得
    LHotspot := GetMouseCursorBitmap(ACursor, LBitmap, True);

    // 透過状態確認のために背景を塗り潰してからビットマップを描画
    Image1.Canvas.Brush.Color := clScrollBar;
    Image1.Canvas.FillRect(LBitmap.Canvas.ClipRect);

    Image1.Canvas.Draw(0, 0, LBitmap);


    // 画像のサイズとホットスポットの値を TPanel に表示
    LText := 'Size :' + IntToStr(LImgSize) + '  '
          + 'xHotspot:' + IntToStr(LHotspot.X) + '  '
          + 'yHotspot:' + IntToStr(LHotspot.Y);
    Panel1.Caption := LText;
  finally
    FreeAndNil(LBitmap);
  end;
end;

end.

//=============================================================================
//  アルファチャンネルを使用している TBitmap を TImaage に描画
//  TBitmap.AlphaFormat の値を afDefined にする
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  LImgFilePath : string;
  LBitmap      : TBitmap;
begin
  LImgFilePath := ExtractFilePath(Application.ExeName) + 'crArrow.bmp';

  LBitmap := TBitmap.Create;
  try
    LBitmap.LoadFromFile(LImgFilePath);

    Image1.Canvas.Draw(0, 0, LBitmap);

    LBitmap.AlphaFormat := afDefined;
    Image2.Canvas.Draw(0, 0, LBitmap);
  finally
    FreeAndNil(LBitmap);
  end;
end;

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

var
  Form1: TForm1;

implementation

uses
  plMouseCursorImage,
  Vcl.Imaging.pngimage;

{$R *.dfm}

//=============================================================================
//  アルファチャンネル付きの TBitmap 画像を PNG 形式の画像に変換して保存
//
//  uses に Vcl.Imaging.pngimag が必要
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  LBitmap      : TBitmap;
  LPngImage    : TPngImage;
  LbmpFilePath : string;
  LSavePath    : string;
begin
  LbmpFilePath := ExtractFilePath(Application.ExeName) + 'crHourGlass.bmp';

  Image1.Picture.Assign(nil);
  Image2.Picture.Assign(nil);
  Image3.Picture.Assign(nil);

  LBitmap := TBitmap.Create;
  try
    LBitmap.LoadFromFile(LbmpFilePath);

    // ここで以下にしないこと
    // afDefinedにしてしまうと PNG 画像の色がおかしくなる
    // LBitmap.AlphaFormat := afDefined;

    // TPngImage 生成
    LPngImage := TPngImage.CreateBlank(COLOR_RGBALPHA, 8, 
                                       LBitmap.Width,LBitmap.Height);
    try
      // TBitmap を TPngImage に変換
      ConvertBitmapToPngimage(LBitmap, LPngImage);

      // 保存
      LSavePath := ChangeFileExt(LbmpFilePath, '.png');
      LPngImage.SaveToFile(LSavePath);

      // TBitmap をアルファチャンネル付きで表示する場合
      // TPngImage に変換してから afDefined にして描画する
      LBitmap.AlphaFormat := afDefined;
      Image1.Canvas.Draw(0, 0, LBitmap);

      // 保存した PNG 画像を読み込んで TImage に描画
      LPngImage.LoadFromFile(LSavePath);
      Image2.Canvas.Draw(0, 0, LPngImage);

      // 透過状態を確認のために背景を塗り潰してから PNG 画像を描画
      Image3.Canvas.Brush.Color := clSilver;
      Image3.Canvas.FillRect(LPngImage.Canvas.ClipRect);
      Image3.Canvas.Draw(0, 0, LPngImage);
    finally
      FreeAndNil(LPngImage);
    end;
  finally
    FreeAndNil(LBitmap);
  end;
end;

end.

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)
    Button1: TButton;
    ListBox1: TListBox;
    Panel1: TPanel;
    Image1: TImage;
    procedure Button1Click(Sender: TObject);
    procedure ListBox1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    { Private 宣言 }
    procedure DrawCursorImage(ACursor: TCursor);
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses
  plMouseCursorImage,
  Winapi.MMSystem;

{$R *.dfm}

//=============================================================================
//  マウスカーソル画像の実画像の矩形領域を取得
//
//  フォーム生成時の処理
//  TListBox に Delphi の TCursor の値の一覧を表示
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
var
  LName  : string;
  LIndex : Integer;
begin
  ListBox1.Items.Clear;
  ListBox1.Items.BeginUpdate;
  for LIndex := -1 downto -22 do begin
    LName := CursorToString(TCursor(LIndex));
    if StrToIntDef(LName, 0) = 0 then begin
      ListBox1.Items.Add(LName);
    end;
  end;
  ListBox1.Items.EndUpdate;
end;

//=============================================================================
//  指定時間が経過したらスクリーンに表示中のカーソル画像をキャプチャ
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  LStartTime  : DWORD;
begin
  // 指定時間が経過したらキャプチャ開始
  LStartTime := timeGetTime;
  while (timeGetTime - LStartTime) < 5000 do begin
    Sleep(10);
    Application.ProcessMessages;
  end;

  DrawCursorImage(0)
end;

//=============================================================================
//  TListBox のカーソル名をクリックしたら，そのマウスカーソルの画像を取得
//=============================================================================
procedure TForm1.ListBox1Click(Sender: TObject);
var
  LItemIndex : Integer;
  LCursor    : TCursor;
  LIndex     : Integer;
begin
  Panel1.Caption := '';
  LItemIndex := ListBox1.ItemIndex;
  if LItemIndex < 0 then Exit;

  Panel1.Caption := '';

  // TListBox で選択した名前から TCursor の値を求める
  LCursor := 0;
  for LIndex := -1 downto -22 do begin
    if LIndex = StringToCursor(ListBox1.Items[LItemIndex]) then begin
      LCursor := LIndex;
      Break;
    end;
  end;

  DrawCursorImage(LCursor);
end;

//-----------------------------------------------------------------------------
//  引数の TCursor 型に該当するマウスカーソル画像を TImage に描画するメソッド
//  ACursor が 0 の時は現在スクリーンに表示中のマウスカーソル画像
//-----------------------------------------------------------------------------
procedure TForm1.DrawCursorImage(ACursor: TCursor);
var
  LBitmap     : TBitmap;
  LSizeBitmap : TBitmap;
  LImgSize    : TSize;
  LText       : string;
begin
  Image1.Picture.Assign(nil);

  LBitmap     := TBitmap.Create;
  LSizeBitmap := TBitmap.Create;
  try
    // マウスカーソルの画像をビットマップ画像として取得
    GetMouseCursorBitmap(ACursor, LBitmap);
    // 実際にカーソル画像が描画されている矩形領域だけをビットマップとして取得
    LImgSize := GetRealCursorImageSize(LBitmap, LSizeBitmap);

    // 透過状態確認のために背景を塗り潰してからビットマップを描画
    Image1.Width  := LImgSize.Width;
    Image1.Height := LImgSize.Height;
    Image1.Canvas.Brush.Color := clSilver;
    Image1.Canvas.FillRect(Image1.Canvas.ClipRect);

    Image1.Canvas.Draw(0, 0, LSizeBitmap);


    // 取得したサイズを表示
    LText := 'width:' + IntToStr(LImgSize.cx) + '  '
           + 'height:' + IntToStr(LImgSize.cy);
    Panel1.Caption := LText;
  finally
    FreeAndNil(LBitmap);
    FreeAndNil(LSizeBitmap);
  end;

end;

end.

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
  TMyHint = class(THintWindow)
  public
    procedure ActivateHint(Rect: TRect; const AHint: string); override;

  end;

  TForm1 = class(TForm)
    Button1: TButton;
    procedure FormCreate(Sender: TObject);
  private
    { Private 宣言 }
  public
    { Public 宣言 }
    FHint : TMyHint;
  end;

var
  Form1: TForm1;

implementation

uses
  plMouseCursorImage;

{$R *.dfm}

//=============================================================================
//  フォーム生成時の処理
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
begin
  // ヒントの表示に使用するクラスを指定して，そのインスタンスを生成
  HintWindowClass := TMyHint;
  FHint := TMyHint.Create(Self);

  Button1.Hint     := 'ヒント' + sLineBreak + 'ヒントの表示位置変更';
  Button1.ShowHint := True;
end;

//=============================================================================
//  THintWindow の継承クラスの ActivateHint メソッド
//  ヒントウィンドウの表示位置を変更
//=============================================================================
procedure TMyHint.ActivateHint(Rect: TRect; const AHint: string);
var
  LPoint : TPoint;
  LSize  : TSize;
begin
  inherited;

  GetCursorPos(LPoint);
  LSize := GetRealCursorImageSize(crArrow);
  Self.Top := LPoint.Y + LSize.Height - 3;
end;

end.

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)
    Button1: TButton;
    PaintBox1: TPaintBox;
    procedure Button1Click(Sender: TObject);
    procedure PaintBox1Paint(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    { Private 宣言 }
  public
    { Public 宣言 }
    FWndBitmap : TBitmap;
  end;

var
  Form1: TForm1;

implementation

uses
  Vcl.Clipbrd,
  Winapi.Dwmapi,
  plMouseCursorImage,
  Winapi.MMSystem;

{$R *.dfm}

//=============================================================================
//  フォーム生成時の処理
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
begin
  FWndBitmap := TBitmap.Create;
end;

//=============================================================================
//  フォーム破棄時の処理
//=============================================================================
procedure TForm1.FormDestroy(Sender: TObject);
begin
  FreeAndNil(FWndBitmap);
end;

//-----------------------------------------------------------------------------
//  ウィンドウのスクリーン上の位置情報を取得
//  Windows Vista 以降の拡張フレーム対応コード
//  uses に Winapi.Dwmapi が必要
//-----------------------------------------------------------------------------
function GetWindowRectForVista(hWnd: HWND): TRect;
var
  LRect : TRect;
begin
  DwmGetWindowAttribute(hWnd, DWMWA_EXTENDED_FRAME_BOUNDS, @LRect, SizeOf(TRect));
  Result := LRect;
end;

//-----------------------------------------------------------------------------
//  アクティブなウィンドウをキャプチャして画像をクリップボードにコピー
//  [Alt] + [Print Screen] のキー操作をエミュレート
//-----------------------------------------------------------------------------
procedure CopyImageActiveWindow;
var
  LKeyFlag : Cardinal;
begin
  // [Alt] + [Print Screen] のキー操作
  LKeyFlag := KEYEVENTF_EXTENDEDKEY;
  keybd_event(VK_MENU,  MapVirtualKey(VK_MENU, 0),  LKeyFlag, 0);
  keybd_event(VK_SNAPSHOT, MapVirtualKey(VK_SNAPSHOT, 0), LKeyFlag, 0);

  LKeyFlag := KEYEVENTF_EXTENDEDKEY or KEYEVENTF_KEYUP;
  keybd_event(VK_MENU,  MapVirtualKey(VK_MENU, 0),  LKeyFlag, 0);
  keybd_event(VK_SNAPSHOT, MapVirtualKey(VK_SNAPSHOT, 0), LKeyFlag, 0);
  Application.ProcessMessages;
  Sleep(100);
end;

//=============================================================================
//  マウスカーソを含めたアクティブウィンドウのキャプチャ
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  LtartTime  : Cardinal;
  LTargetWnd : HWND;
  LCursorBmp : TBitmap;
  LWndRect   : TRect;
  LCursorPos : TPoint;
  LHotspot   : TPoint;
begin
  // テスト用に用意したウィンドウを最前面に表示
  LTargetWnd := FindWindow('TCaptureWindow', nil);
  SetForegroundWindow(LTargetWnd);

  // 指定時間が経過したらキャプチャ
  LtartTime := timeGetTime;
  while (timeGetTime - LtartTime) < 5000 do begin
    Sleep(10);
    Application.ProcessMessages;
  end;


  // アクティブなウィンドウの位置とマウスカーソルの位置を取得
  LTargetWnd := GetForegroundWindow;
  LWndRect   := GetWindowRectForVista(LTargetWnd);
  GetCursorPos(LCursorPos);


  // アクティブなウィンドウをキャプチャ
  CopyImageActiveWindow;

  LCursorBmp := TBitmap.Create;
  try
    // キャプチャしたウィンドウの画像を取得
    FWndBitmap.Assign(Clipboard);

    // マウスカーソルの画像をキャプチャ
    LHotspot := GetMouseCursorBitmap(LCursorBmp, True);

    // マウスカーソルの画像を描画する位置を計算
    LCursorPos.X := LCursorPos.X - LWndRect.Left - LHotspot.X;
    LCursorPos.Y := LCursorPos.Y - LWndRect.Top - LHotspot.Y;

    // ウィンドウの画像にカーソル画像を重ね描画．それを TPaintBox に描画
    FWndBitmap.Canvas.Draw(LCursorPos.X, LCursorPos.Y, LCursorBmp);
    PaintBox1.Invalidate;
  finally
    FreeAndNil(LCursorBmp);
  end;

  SetForegroundWindow(Handle);
end;

//=============================================================================
//  PaintBox1 の OnPaint イベント
//  キャプチャした画像を描画
//=============================================================================
procedure TForm1.PaintBox1Paint(Sender: TObject);
begin
  PaintBox1.Canvas.Brush.Color := clSilver;
  PaintBox1.Canvas.FillRect(PaintBox1.Canvas.ClipRect);

  if FWndBitmap <> nil then begin
    PaintBox1.Canvas.Draw(0, 0, FWndBitmap);
  end;
end;

end.

//=============================================================================
//  フォーム生成時の処理
//  Delphi の TCursor 型の値を列挙
//=============================================================================
procedure TCaptureWindow.FormCreate(Sender: TObject);
var
  LName  : string;
  LIndex : Integer;
begin
  ListBox1.Items.Clear;
  ListBox1.Items.BeginUpdate;
  for LIndex := -1 downto -22 do begin
    LName := CursorToString(TCursor(LIndex));
    if StrToIntDef(LName, 0) = 0 then begin
      ListBox1.Items.Add(LName);
    end;
  end;
  ListBox1.Items.EndUpdate;
end;

//=============================================================================
//  TListBox のカーソル名を選択したらそのカーソルを Sreen.Cursor にする
//=============================================================================
procedure TCaptureWindow.ListBox1Click(Sender: TObject);
var
  LIndex  : Integer;
  LCursor : TCursor;
begin
  Lindex := ListBox1.ItemIndex;
  if Lindex < 0 then Exit;

  for LIndex := -1 downto -22 do begin
    if LIndex = StringToCursor(ListBox1.Items[ListBox1.ItemIndex]) then begin
      LCursor := Lindex;
      Break;
    end;
  end;
  Screen.Cursor := LCursor;
end;

//=============================================================================
//  TListBox にカーソルが移動したら Screen.Cursor をデフォルトにする
//=============================================================================
procedure TCaptureWindow.ListBox1MouseEnter(Sender: TObject);
begin
  Screen.Cursor := crDefault;
end;

unit plMouseCursorImage;

interface

uses
  Winapi.Windows, System.SysUtils, Vcl.Graphics, Vcl.Controls, Vcl.Forms, System.Classes,
  Vcl.Imaging.pngimage, Vcl.Dialogs;


  function GetMouseCursorBitmap(ABitmap: TBitmap;
    ADropShadow: Boolean = False): TPoint; overload;
  function GetMouseCursorBitmap(CursorID: TCursor; ABitmap: TBitmap;
    ADropShadow: Boolean = False): TPoint; overload;
  function GetMouseCursorSize: Integer;
  function GetMouseCursorFilePath(CursorID: TCursor): string; overload;
  function GetRealCursorImageSize(ABitmap: TBitmap; ADstBitmap:
    TBitmap = nil): TSize; overload;
  function GetRealCursorImageSize(ACursor: TCursor;
    ADstBitmap: TBitmap = nil): TSize; overload;
  procedure CreateMaskBitmapOpacity(ABitmap: TBitmap; Opacity: Byte);
  procedure GaussianBlur(ASrcBmp: TBitmap; ARadius, ARepeat: Integer);
  function ConvertBitmapToPngimage(SrcBitmap: TBitmap;
    DstPngImage: TPngImage): Boolean;

var
  FMouseCursorFilePath : string;

implementation

uses
  System.Win.Registry,
  System.StrUtils,
  System.Types;

type
  TRGBQuadArray = array [0..MaxInt div SizeOf(TRGBQuad) - 1] of TRGBQuad;
  PRGBQuadArray = ^TRGBQuadArray;
  TRGBTArray = array [0..MaxInt div SizeOf(TRGBTRIPLE) - 11] of RGBTRIPLE;
  PRGBTripleArray = ^TRGBTArray;


//-----------------------------------------------------------------------------
//  マスク画像から元の画像を生成する処理
//  24 bit 以下で作成されたマウスカーソル画像で必要な処理
//
//  ASrcBitmap  : DrawIconEx でフラグを DI_NORMAL にして取得したビットマップ
//  AImgBitmap  : DrawIconEx でフラグを DI_IMAGE にして取得したビットマップ
//                LImgBitmap.AlphaFormat := afDefined にしておく
//                これが処理後のビットマップとなる
//  AMaskBitmap : DrawIconEx でフラグを DI_MASK にして取得したビットマップ
//
//  24 bit 以下の画像を PixelFormat で 32 bit にするとアルファ値は 0 になる
//  元々アルファを使用している場合はそのアルファ値が取得できる
//  この手続きの処理はこのことを利用して 32 bit と 24 bit 以下の判定をしている
//-----------------------------------------------------------------------------
procedure MakeCursorBmpByMaskBmp(ASrcBitmap, AImgBitmap, AMaskBitmap: TBitmap);
var
  LRedSrc        : Byte;
  LGreenSrc      : Byte;
  LBlueSrc       : Byte;
  LAlphaSrc      : Byte;
  LRedMask       : Byte;
  LGreenMask     : Byte;
  LBlueMask      : Byte;
  LYPos          : Integer;
  LXPos          : Integer;
  LScanArraySrc  : PRGBQuadArray;
  LScanArrayImg  : PRGBQuadArray;
  LScanArrayMask : PRGBQuadArray;
begin
  ASrcBitmap.Canvas.Lock;
  AImgBitmap.Canvas.Lock;
  AMaskBitmap.Canvas.Lock;

  try
    for LYPos := 0 to AMaskBitmap.Height - 1 do begin
      LScanArraySrc := ASrcBitmap.ScanLine[LYPos];
      LScanArrayImg := AImgBitmap.ScanLine[LYPos];
      LScanArrayMask := AMaskBitmap.ScanLine[LYPos];

      for LXPos := 0 to AMaskBitmap.Width - 1 do begin
        // 退避
        LRedSrc   := LScanArraySrc[LXPos].rgbRed;
        LGreenSrc := LScanArraySrc[LXPos].rgbGreen;
        LBlueSrc  := LScanArraySrc[LXPos].rgbBlue;
        LAlphaSrc := LScanArraySrc[LXPos].rgbReserved;

        // マスク画像のピクセルの色．黒か白
        LRedMask   := LScanArrayMask[LXPos].rgbRed;
        LGreenMask := LScanArrayMask[LXPos].rgbGreen;
        LBlueMask  := LScanArrayMask[LXPos].rgbBlue;

        if (LRedMask = 0) and (LGreenMask = 0) and (LBlueMask = 0) then begin
          if LAlphaSrc = 0 then begin
            // アルファチャンネルを使用していないカーソル画像の場合
            // マスク部分のピクセルに色データをセット
            // アルファチャンネルを使用するビットマップにしてしまう
            LScanArrayImg[LXPos].rgbRed      := LRedSrc;
            LScanArrayImg[LXPos].rgbGreen    := LGreenSrc;
            LScanArrayImg[LXPos].rgbBlue     := LBlueSrc;
  　　      LScanArrayImg[LXPos].rgbReserved := $FF;
          end else begin
            // アルファ値がある場合
            // AImgBitmapGE は目的のカーソル画像なので処理は不要
            Exit;
          end;
        end;
      end;
    end;
  finally
    ASrcBitmap.Canvas.Unlock;
    AImgBitmap.Canvas.Unlock;
    AMaskBitmap.Canvas.Unlock;
  end;
end;

////-----------------------------------------------------------------------------
//  マスク画像が有効かをチェック
//  Windows 10 の Aero でないカーソルでマスク画像を省略しているカーソルがある
//  現在確認しているのは Crosshair, IBeam
//  これらはマスク画像がなくても背景を透過表示することが可能
//  ゴミが入っている場合があるので背景色でないピクセル数を取得して確認
//  (歴史的産物か ?)
//-----------------------------------------------------------------------------
function CheckMaskBmp(AMaskBitmap: TBitmap): Integer;
var
  LColor         : TColor;
  LRTrans        : Byte;
  LGTrans        : Byte;
  LBTrans        : Byte;
  LRMask         : Byte;
  LGMask         : Byte;
  LBMask         : Byte;
  LYPos          : Integer;
  LXPos          : Integer;
  LScanArrayMask : PRGBQuadArray;
begin
  Result := 0;
  AMaskBitmap.Canvas.Lock;

  LColor := AMaskBitmap.Canvas.Pixels[0, AMaskBitmap.Height - 1];
  LRTrans := GetRValue(LColor);
  LGTrans := GetGValue(LColor);
  LBTrans := GetBValue(LColor);

  try
    for LYPos := 0 to AMaskBitmap.Height - 1 do begin
      LScanArrayMask := AMaskBitmap.ScanLine[LYPos];

      for LXPos := 0 to AMaskBitmap.Width - 1 do begin

        LRMask := LScanArrayMask[LXPos].rgbRed;
        LGMask := LScanArrayMask[LXPos].rgbGreen;
        LBMask := LScanArrayMask[LXPos].rgbBlue;

        if (LRMask = LRTrans) and (LGMask = LGTrans) and (LBMask = LBTrans) then begin
        end else begin
          Result := Result + 1;
        end;
      end;
    end;
  finally
    AMaskBitmap.Canvas.Unlock;
  end;
end;

//-----------------------------------------------------------------------------
//  白黒を反転してマスク画像作成
//  Aero でないカーソル画像でマスク画像がない画像用
//  確認しているのは Crosshair, IBeam
//  この時，DI_IMAGE で取得した画像がマスクの反転画像と同じなのでそれを利用
//-----------------------------------------------------------------------------
function MakeMasBmpForWin10(AMaskBitmap, AImgBitmap: TBitmap): Boolean;
var
  LRImg          : Byte;
  LGImg          : Byte;
  LBImg          : Byte;
  LYPos          : Integer;
  LXPos          : Integer;
  LScanArrayMask : PRGBQuadArray;
  LScanArrayImg  : PRGBQuadArray;
begin
  Result := True;
  AMaskBitmap.Canvas.Lock;
  AImgBitmap.Canvas.Lock;

  try
    for LYPos := 0 to AMaskBitmap.Height - 1 do begin
      LScanArrayMask := AMaskBitmap.ScanLine[LYPos];
      LScanArrayImg  := AImgBitmap.ScanLine[LYPos];

      for LXPos := 0 to AMaskBitmap.Width - 1 do begin

        LRImg := LScanArrayImg[LXPos].rgbRed;
        LGImg := LScanArrayImg[LXPos].rgbGreen;
        LBImg := LScanArrayImg[LXPos].rgbBlue;

        if (LRImg = 0) and (LGImg = 0) and (LBImg = 0) then begin
          LScanArrayMask[LXPos].rgbRed      := $FF;
          LScanArrayMask[LXPos].rgbGreen    := $FF;
          LScanArrayMask[LXPos].rgbBlue     := $FF;
          LScanArrayMask[LXPos].rgbReserved := $FF;
        end else begin
          LScanArrayMask[LXPos].rgbRed      := 0;
          LScanArrayMask[LXPos].rgbGreen    := 0;
          LScanArrayMask[LXPos].rgbBlue     := 0;
          LScanArrayMask[LXPos].rgbReserved := $FF;
        end;
      end;
    end;
  finally
    AMaskBitmap.Canvas.Unlock;
    AImgBitmap.Canvas.Unlock;
  end;
end;

//-----------------------------------------------------------------------------
//  マウスカーソルのビットマップ画像を取得するメインルーチン
//
//  AFilePath  : マウスカーソルファイルのフルパス名
//               環境変数を含まないこと
//               空文字の時は AhCursor (カーソルハンドル) の値から取得
//  AhCursor    : マウスカーソルのハンドルの値
//  ABitmap     : 出力の 32 bit アルファチャンネル付きビットマップ
//  ADropShadow : True ならマウスカーソルに影を描画
//                Windows では全てのマウスカーソルに影を描画しているわけではない
//
//  戻り値は TPoint 型で，ホットスポット (Hotspot) の値
//  ホットスポットの値は全て比率計算の結果
//-----------------------------------------------------------------------------
function GetMouseCursorBitmapImage(AFilePath: string; AhCursor: HCURSOR;
  ABitmap: TBitmap; ADropShadow: Boolean): TPoint;
var
  LAeroFlag   : Boolean;
  LIconSize   : integer;
  LDeffSize   : Integer;
  LhCursor    : HCURSOR;
  LIconInfo   : TIconInfo;
  LImgBitmap  : TBitmap;
  LMaskBitmap : TBitmap;
  LTransColor : TColor;
  LHasShadow  : Boolean;
begin
  Result := Point(0, 0);
  FMouseCursorFilePath := '';
  if (AFilePath = '') and (AhCursor = 0) then Exit;

  LIconSize := GetMouseCursorSize;
  LDeffSize := GetSystemMetrics(SM_CXCURSOR);
  if LIconSize = 0 then Exit;
  LhCursor := 0;

  LAeroFlag := (AFilePath <> '') and (LeftStr(ExtractFileName(AFilePath), 5) = 'aero_');

  // Windows にマウスカーソルファイルがあり Aero カーソルの場合
  // デフォルトの最小サイズの時の Crosshair; IBeam はファイルなしとなっている
  // 実際には次の Aero でないカーソル画像のコードでも取得できる
  if LAeroFlag then begin
    FMouseCursorFilePath := AFilePath;
    ABitmap.SetSize(LIconSize, LIconSize);
    if LIconSize = LDeffSize then begin
      LhCursor := LoadImage(HInstance, PChar(AFilePath), IMAGE_CURSOR,
                            0, 0, LR_DEFAULTSIZE or LR_LOADFROMFILE);
    end else begin
      LhCursor := LoadImage(HInstance, PChar(AFilePath), IMAGE_CURSOR,
                            0, 0, LR_LOADFROMFILE);
    end;

    ABitmap.SetSize(LIconSize, LIconSize);
    DrawIconEx(ABitmap.Canvas.Handle, 0, 0, LhCursor,
               LIconSize, LIconSize, 0, 0, DI_IMAGE);

    ABitmap.PixelFormat := pf32bit;
    ABitmap.AlphaFormat := afDefined;
  end;

  // Windows Aero 以外のカーソル画像 (Delphi 専用とその他のマウスカーソル)
  // 引数のカーソルハンドルを使用して画像を取得
  // 実際には Aero のカーソル画像もこのコードで取得できる
  if not LAeroFlag then begin
    LImgBitmap  := TBitmap.Create;
    LMaskBitmap := TBitmap.Create;

    try
      ABitmap.SetSize(LIconSize, LIconSize);
      LImgBitmap.SetSize(LIconSize, LIconSize);
      LMaskBitmap.SetSize(LIconSize, LIconSize);

      DrawIconEx(ABitmap.Canvas.Handle, 0, 0, AhCursor,
                   LIconSize, LIconSize, 0, 0, DI_NORMAL);
      DrawIconEx(LImgBitmap.Canvas.Handle, 0, 0, AhCursor,
                     LIconSize, LIconSize, 0, 0, DI_IMAGE);
      DrawIconEx(LMaskBitmap.Canvas.Handle, 0, 0, AhCursor,
                     LIconSize, LIconSize, 0, 0, DI_MASK);

      ABitmap.PixelFormat      := pf32bit;
      LImgBitmap.PixelFormat  := pf32bit;
      LMaskBitmap.PixelFormat := pf32bit;

      // アルファチャンネル使用のビットマップか調べる
      // これで Aero かも判定可能
      LTransColor := LMaskBitmap.Canvas.Pixels[0, LMaskBitmap.Height - 1];
      if LTransColor = 0 then begin
        LImgBitmap.AlphaFormat := afDefined;
        ABitmap.Assign(LImgBitmap);
      end else begin
        // マスク画像がある場合
        // マスク画像を省略しているカーソルがあるのでチェック
        if CheckMaskBmp(LMaskBitmap) <= 10 then begin
          MakeMasBmpForWin10(LMaskBitmap, LImgBitmap);
        end;
        // 以下で 32 bit か 24 bit 以下かを判定して処理する
        LImgBitmap.AlphaFormat := afDefined;
        MakeCursorBmpByMaskBmp(ABitmap, LImgBitmap, LMaskBitmap);
        ABitmap.Assign(LImgBitmap);
      end;
    finally
      FreeAndNil(LImgBitmap);
      FreeAndNil(LMaskBitmap);
    end;
  end;


  // ホットスポット
  // Aero であっても [マウスのプロパティ] でデザインを変更している場合
  // ホットスポットの値が正確に取得できない場合があるので全て比率計算とする
  GetIconInfo(AhCursor, LIconInfo);
  Result.X := Trunc(LIconSize * Integer(LIconInfo.xHotspot) / LDeffSize);
  Result.Y := Trunc(LIconSize * Integer(LIconInfo.yHotspot) / LDeffSize);


  // マウスカーソルの影の描画
  // [マウスのプロパティ] [ポインタ]で[ポインタの影を有効にする] をチェック
  // チェックがなければ影の描画は行わない

  SystemParametersInfo(SPI_GETCURSORSHADOW, 0, @LHasShadow, 0);

  if ADropShadow and LHasShadow and (AFilePath <> '')
      and (ExtractFileExt(AFilePath) <> '.ani') then begin
    LMaskBitmap := TBitmap.Create;
    LImgBitmap  := TBitmap.Create;
    try
      LMaskBitmap.PixelFormat := pf32bit;
      LMaskBitmap.AlphaFormat := afDefined;
      LImgBitmap.PixelFormat := pf32bit;
      LImgBitmap.AlphaFormat := afDefined;

      LMaskBitmap.Assign(ABitmap);
      LImgBitmap.Assign(ABitmap);
      CreateMaskBitmapOpacity(LImgBitmap, 0);

      CreateMaskBitmapOpacity(LMaskBitmap, 70);
      GaussianBlur(LMaskBitmap, 1, 1);

      LImgBitmap.Canvas.Draw(2, 1, LMaskBitmap);
      LImgBitmap.Canvas.Draw(0, 0, ABitmap);
      ABitmap.Assign(LImgBitmap);
    finally
      FreeAndNil(LImgBitmap);
      FreeAndNil(LMaskBitmap);
    end;
  end;

  if LhCursor <> 0 then DestroyCursor(LhCursor);
  if LIconInfo.hbmColor <> 0 then DeleteObject(LIconInfo.hbmColor);
  if LIconInfo.hbmMask <> 0 then DeleteObject(LIconInfo.hbmMask);
end;

//-----------------------------------------------------------------------------
//  現在スクリーンに表示れているマウスカーソルのハンドルを取得する関数
//-----------------------------------------------------------------------------
function GetShowCursorHandle: HCURSOR;
var
  LCursorInfo : TCursorInfo;
begin
  LCursorInfo.cbSize := SizeOf(TCursorInfo);
  LCursorInfo.flags  := CURSOR_SHOWING;
  GetCursorInfo(LCursorInfo);
  Result := LCursorInfo.hCursor;
end;

//=============================================================================
//  マウスカールをビットマップ画像として取得
//
//  ABitmap     : 出力の 32 bit アルファチャンネル付きビットマップ
//  ADropShadow : True にするとカーソルに影を描画
//
//  戻り値は TPoint 型で，ホットスポット (Hotspot) の値
//=============================================================================
function GetMouseCursorBitmap(ABitmap: TBitmap;
  ADropShadow: Boolean = False): TPoint;
var
  LhCursor  : HCURSOR;
  LCursorID : TCursor;
  LFilePath : string;
  LIndex    : Integer;
begin
  LFilePath := '';
  LhCursor := GetShowCursorHandle;

  // カーソルのハンドルから TCursor の値を取得
  LCursorID := 0;
  for LIndex := -1 downto -22 do begin
    if LhCursor = Screen.Cursors[LIndex] then begin
      LCursorID := TCursor(LIndex);
      Break;
    end;
  end;

  // TCursor の値に相当するカーソルファイルがあるか調べる
  if LCursorID <> 0 then begin
    LFilePath := GetMouseCursorFilePath(LCursorID);
  end;

  Result := GetMouseCursorBitmapImage(LFilePath, LhCursor, ABitmap, ADropShadow);
  if LhCursor <> 0 then DestroyCursor(LhCursor);
end;

//=============================================================================
//  マウスカールをビットマップ画像として取得
//  Delphi の TCursor 型を指定する場合
//  主にテスト用 (Delphi の自アプリ内であれば TCursor は Screen.Cursor の値)
//
//  CursorID   : Delphi の TCursor 型の値 (crArrow 等)
//  ABitmap     : 出力の 32 bit アルファチャンネル付きビットマップ
//  ADropShadow : True にするとカーソルに影を描画
//
//  戻り値は TPoint 型で，ホットスポット (Hotspot) の値
//=============================================================================
function GetMouseCursorBitmap(CursorID: TCursor; ABitmap: TBitmap;
  ADropShadow: Boolean = False): TPoint;
var
  LhCursor  : HCURSOR;
  LFilePath : string;
  LIndex    : Integer;
begin
  if CursorID = 0 then begin
    Result := GetMouseCursorBitmap(ABitmap, ADropShadow);
    Exit;
  end;

  // 引数と同じ TCursor の値があるか調べてスクリーンカーソルのハンドルを取得
  LhCursor := 0;
  for LIndex := -1 downto -22 do begin
    if  CursorID = TCursor(LIndex) then begin
      LhCursor := Screen.Cursors[LIndex];
      Break;
    end;
  end;
  if LhCursor = 0 then Exit;

  // TCursor の値に相当するカーソルファイルがあるか調べる
  if LhCursor <> 0 then begin
    LFilePath := GetMouseCursorFilePath(CursorID);
  end;

  Result := GetMouseCursorBitmapImage(LFilePath, LhCursor, ABitmap, ADropShadow);
  if LhCursor <> 0 then DestroyCursor(LhCursor);
end;

//=============================================================================
//  現在のマウスカーソルのサイズを取得
//=============================================================================
function GetMouseCursorSize: Integer;
var
  LRegistry   : TRegistry;
  LKeyName    : string;
begin
  Result := 0;

  LRegistry := TRegistry.Create;
  try
    LRegistry.Access  := KEY_READ;
    LRegistry.RootKey := HKEY_CURRENT_USER;
    LKeyName :='Control Panel\Cursors';

    if LRegistry.OpenKey(LKeyName, False) then begin
      Result := LRegistry.ReadInteger('CursorBaseSize');
      LRegistry.CloseKey;
    end;
  finally
    FreeAndNil(LRegistry);
  end;
end;

//-----------------------------------------------------------------------------
//  環境変数を含む文字列から実際のフルパスを取得する関数
//-----------------------------------------------------------------------------
function ExpandEnvironmentString(S: string): string;
var
  LDstChar : array [0..MAX_PATH-1] of Char;
begin
  ExpandEnvironmentStrings(PChar(S), LDstChar, MAX_PATH);
  Result := LDstChar;
end;

//=============================================================================
//  Delphi の TCursor 型の値からからカーソルファイルのフルパスを取得
//  Windows にないカーソルの時は空文字を返す
//=============================================================================
function GetMouseCursorFilePath(CursorID: TCursor): string;
var
  LRegistry : TRegistry;
  LItemName : string;
  LKeyName  : string;
begin
  Result := '';

  case CursorID of
    crArrow     : LItemName := 'Arrow';
    crCross     : LItemName := 'Crosshair';
    crIBeam     : LItemName := 'IBeam';
    crSizeNESW  : LItemName := 'SizeNESW';
    crSizeNS    : LItemName := 'SizeNS';
    crSizeNWSE  : LItemName := 'SizeNWSE';
    crSizeWE    : LItemName := 'SizeWE';
    crUpArrow   : LItemName := 'UpArrow';
    crHourGlass : LItemName := 'Wait';
    crDrag      : LItemName := '';
    crNoDrop    : LItemName := '';
    crHSplit    : LItemName := '';
    crVSplit    : LItemName := '';
    crMultiDrag : LItemName := '';
    crSQLWait   : LitemName := '';
    crNo        : LItemName := 'No';
    crAppStart  : LItemName := 'Appstarting';
    crHelp      : LItemName := 'Help';
    crHandPoint : LItemName := 'Hand';
    crSizeAll   : LItemName := 'SizeAll';
  else
    LItemName := '';
  end;
  if LItemName = '' then Exit;

  LRegistry := TRegistry.Create;
  try
    LRegistry.Access  := KEY_READ;
    LRegistry.RootKey := HKEY_CURRENT_USER;
    LKeyName :='Control Panel\Cursors';

    if LRegistry.OpenKey(LKeyName, False) then begin
      Result := LRegistry.ReadString(LItemName);
      // 環境変数が含まれている場合があるので実パスに変換
      Result := ExpandEnvironmentString(Result);

      LRegistry.CloseKey;
    end;
  finally
    FreeAndNil(LRegistry);
  end;
end;

//-----------------------------------------------------------------------------
//  透明色 (または透過色) を除いた矩形領域を切り取った画像とそのサイズを取得
//  24 bit, 32 bit 兼用．出力は元のビットマップと同じ bit 数
//
//  ABitmap     : 元のビットマップ
//  ADstBitmaap : 処理後のビットマップ
//                色のビット数は元のビットマップの色ビット数と同じ
//                結果としてのビットマップ゜が必要なければ nil を渡す
//
//  戻り値は TSize 型で処理後のビットマップの幅と高さ
//-----------------------------------------------------------------------------
function GetRealBitmapImageSize(ABitmap: TBitmap; ADstBitmap: TBitmap): TSize;
var
  LBitmap       : TBitmap;
  LWidth    　  : Integer;
  LHeight     　: Integer;
  LXPos         : integer;
  LYPos         : Integer;
  LScanArraySrc : PRGBQuadArray;
  LScanArrayDst : PRGBQuadArray;
  LColorDst     : RGBQUAD;

  LTransColor   : TColor;
  LTransR       : Byte;
  LTransG       : Byte;
  LTransB       : Byte;
  LRValue       : Byte;
  LGValue       : Byte;
  LBValue       : Byte;
  LAValue       : Byte;
  LIsTrans      : Boolean;
  LImgLeft      : Integer;
  LImgRight     : Integer;
  LImgTop    　 : Integer;
  LImgbottom 　 : Integer;
  LInImageY     : Boolean;
  LInImageX     : Boolean;
begin
  Result.Width  := 0;
  Result.Height := 0;

  ABitmap.Canvas.Lock;
  if ADstBitmap <> nil then ADstBitmap.Canvas.Lock;

  LBitmap:= TBitmap.Create;
  try
    LBitmap.Assign(ABitmap);
    LBitmap.PixelFormat := pf32bit;

    if ADstBitmap <> nil then begin
      ADstBitmap.PixelFormat := pf32bit;
    end;

    LWidth  := LBitmap.Width;
    LHeight := LBitmap.Height;

    LTransColor := LBitmap.Canvas.Pixels[0, LBitmap.Height - 1];
    LTransR := GetRValue(LTransColor);
    LTransG := GetGValue(LTransColor);
    LTransB := GetBValue(LTransColor);

    // 切り取り矩形領域の上下左右の値
    LImgLeft   := LWidth - 1;
    LImgRight  := 0;
    LImgTop    := 0;
    LImgbottom := 0;

    LInImageY := False;


    // 全ピクセルの色を調査．透過色のピクセルを調べていく
    for LYPos := 0 to LHeight - 1 do begin
      LScanArraySrc := LBitmap.ScanLine[LYPos];
      LInImageX := False;

      for LXPos := 0 to LWidth - 1 do begin
        LRValue := LScanArraySrc[LXPos].rgbRed;
        LGValue := LScanArraySrc[LXPos].rgbGreen;
        LBValue  := LScanArraySrc[LXPos].rgbBlue;
        LAValue  := LScanArraySrc[LXPos].rgbReserved;


        if LTransColor = 0 then begin
          LIsTrans := (LAValue = 0);
        end else begin
          LIsTrans := (LRValue = LTransR) and (LGValue = LTransG) and (LBValue = LTransB);
        end;

        // 切り取り領域の値を計算
        if LIsTrans then begin
          if not LInImageY then begin
            if LYPos <= LImgTop then begin
              LImgTop := LYPos + 1;
            end;
          end;
        end else begin
          LInImageY := True;
        end;

        if not LIsTrans then begin
          if not LInImageX then begin
            if LXPos <= LImgLeft then begin
              LImgLeft:= LXPos;
            end;
            LInImageX := True;
          end;
          if LXPos >= LImgRight then begin
            LImgRight := LXPos;
          end;
          if LYPos >= LImgBottom then begin
            LImgBottom := LYPos;
          end;
        end;
      end;
    end;


    LWidth  := LImgRight - LImgLeft;
    LHeight := LImgbottom - LImgTop;

    // 元のビットマップの各画像の値を出力先のビットマップの画素に代入していく
    if ADstBitmap <> nil then begin
      ADstBitmap.SetSize(LWidth, LHeight);
      for LYPos := 0 to LHeight - 1 do begin
        LScanArraySrc   := LBitmap.ScanLine[LYPos + LImgTop];
        LScanArrayDst := ADstBitmap.ScanLine[LYPos];

        for LXPos := 0 to LWidth - 1 do begin
          LColorDst.rgbRed      := LScanArraySrc[LXPos + LImgLeft].rgbRed;
          LColorDst.rgbGreen    := LScanArraySrc[LXPos + LImgLeft].rgbGreen;
          LColorDst.rgbBlue     := LScanArraySrc[LXPos + LImgLeft].rgbBlue;
          LColorDst.rgbReserved := LScanArraySrc[LXPos + LImgLeft].rgbReserved;

          LScanArrayDst[LXPos] := LColorDst
        end;
      end;
    end;
  finally
    FreeAndNil(LBitmap);
  end;

  ABitmap.Canvas.Unlock;
  if ADstBitmap <> nil then begin
    if LTransColor = 0 then ADstBitmap.AlphaFormat := afDefined;
    if ABitmap.PixelFormat = pf24bit then begin
      ADstBitmap.PixelFormat := pf24bit;
      ADstBitmap.Transparent := ABitmap.Transparent;
    end;
    ADstBitmap.Canvas.Unlock;
  end;

  Result.Width  := LWidth;
  Result.Height := LHeight;
end;

//============================================================================
//  マウスカーソル画像の透明部分を除いた画像の矩形領域を取得
//  スクリーン上のマウスカーソルが対象
//
//  ABitmap    : 元のマウスカーソルのビットマップ画像
//  ADstBitmap : 出力．切り取った 32 bit のビットマップ
//               画像が不要であれば nil を渡す
//
//  戻り値値は TSize 型で，切り取った結果としての画像のサイズ
//============================================================================
function GetRealCursorImageSize(ABitmap: TBitmap;
  ADstBitmap: TBitmap = nil): TSize;
begin
  Result := GetRealBitmapImageSize(ABitmap, ADstBitmap);
end;

//============================================================================
//  マウスカーソル画像の透明部分を除いた画像の矩形領域を取得
//  Delphi の TCursor 型のマウスカーソルが対象 (crArrow 等)
//
//  CursorID   : Delphi の TCursor 型の値 (crArrow 等)
//               0 にするとスクリーン上のマウスカーソルが対象
//  ADstBitmap : 出力．切り取ったビットマップ
//               画像が不要であれば nil を渡す
//
//  戻り値値は TSize 型で，切り取った結果としての画像のサイズ
//============================================================================
function GetRealCursorImageSize(ACursor: TCursor;
  ADstBitmap: TBitmap = nil): TSize;
var
  LBitmap : TBitmap;
  LPoint  : TPoint;
begin
  Result.Width  := 0;
  Result.Height := 0;

  LBitmap := TBitmap.Create;
  try
    LPoint := GetMouseCursorBitmap(ACursor, LBitmap);
    Result := GetRealBitmapImageSize(LBitmap, ADstBitmap);
  finally
    FreeAndNil(LBitmap);
  end;
end;

//=============================================================================
//  マウスカーソルの半透明マスク画像の作成
//  マウスカーソルの影部分の作成用
//  32 bit 用
//
//  与えられたビットマップの左下のピクセルと同じ色のピクセルを透明化する
//  それ以外のピクセルは，透過度をOpadityで指定する値にする
//
//  ABitmap : 処理対象のビットマップ．処理したビットマップを返す
//  Opacity : 透明度．0 なら完全に透明
//
//  32 bit でアルファチャンネルが有効なビットマップ専用
//=============================================================================
procedure CreateMaskBitmapOpacity(ABitmap: TBitmap; Opacity: Byte);
var
  LTransColor : TColor;
  LFlag       : Boolean;
  LTransR     : Byte;
  LTransG     : Byte;
  LTransB     : Byte;
  LRed        : Byte;
  LGreen      : Byte;
  LBlue       : Byte;
  LAlpha      : Byte;
  LYPos       : Integer;
  LXPos       : Integer;
  LScanArray  : PRGBQuadArray;
begin
  ABitmap.Canvas.Lock;

  // 指定色の R,G,B の各値を取得しておく
  LTransColor := ABitmap.Canvas.Pixels[0, ABitmap.Height - 1];
  LTransR := GetRValue(LTransColor);
  LTransG := GetGValue(LTransColor);
  LTransB := GetBValue(LTransColor);

  for LYPos := 0 to ABitmap.Height - 1 do begin
    LScanArray := ABitmap.ScanLine[LYPos];

    for LXPos := 0 to ABitmap.Width - 1 do begin
      LRed   := LScanArray[LXPos].rgbRed;
      LGreen := LScanArray[LXPos].rgbGreen;
      LBlue  := LScanArray[LXPos].rgbBlue;
      LAlpha := LScanArray[LXPos].rgbReserved;

      LScanArray[LXPos].rgbRed      := 0;
      LScanArray[LXPos].rgbGreen    := 0;
      LScanArray[LXPos].rgbBlue     := 0;

      if LTransColor = 0 then begin
        LFlag := ( LAlpha = 0);
      end else begin
        LFlag := (LTransR = LRed) and (LTransG = LGreen) and (LTransB = LBlue);
      end;
      if LFlag then begin
        LScanArray[LXPos].rgbReserved := 0;
      end else begin
        LScanArray[LXPos].rgbReserved := Opacity;
      end;
    end;
  end;

  ABitmap.Canvas.Unlock;
end;

//=============================================================================
//  TBitmap をウスぼかし画像にする
//  32 bit 用
//
//  ARadius : ほかしの半径
//  ARepeat : 繰り返し回数
//
//  32 bit のビットマップ専用
//=============================================================================
procedure GaussianBlur(ASrcBmp: TBitmap; ARadius, ARepeat: Integer);
var
  LDstBmp      : TBitmap;
  LYRepeatCnt  : Integer;
  LXRepeatCnt  : Integer;
  LDiameter    : Integer;
  LImgWidth    : Integer;
  LImgHeight   : Integer;
  LPosX        : Integer;
  LPosY        : Integer;
  LPixel1      : Integer;
  LPixel2      : Integer;
  LCalcX       : Integer;
  LCalcY       : Integer;
  LScanLineDst : PRGBQuadArray;
  LpARGB       : PRGBQuad;
  LAlpha       : array of Integer;
  LRed         : array of Integer;
  LGreen       : array of Integer;
  LBlue        : array of Integer;
  LScanStart   : Integer;
  LDistance    : Integer;
  LBytesShift  : Integer;
begin
  ASrcBmp.Canvas.Lock;

  LDstBmp := TBitmap.Create;
  try
    LDstBmp.Assign(ASrcBmp);

    if ARadius = 0 then exit;

    LDiameter  := (ARadius * 2) + 1;
    if ASrcBmp.PixelFormat = pf32bit then begin
      LBytesShift := SizeOf(TRGBQuad);
    end else begin
      LBytesShift := SizeOf(TRGBTriple);
    end;

    LImgWidth  := LDstBmp.Width - 1;
    LImgHeight := LDstBmp.Height - 1;

    //計算範囲を (幅 x 半径 x2 + 1) に拡張
    SetLength(LAlpha, LImgWidth + 1 + (ARadius * 2));
    SetLength(LRed,   LImgWidth + 1 + (ARadius * 2));
    SetLength(LGreen, LImgWidth + 1 + (ARadius * 2));
    SetLength(LBlue,  LImgWidth + 1 + (ARadius * 2));

    LScanLineDst := LDstBmp.ScanLine[0];
    LDistance    := integer(LDstBmp.ScanLine[1]) - integer(LScanLineDst);

    LScanStart := Integer(LScanLineDst);

    for LPosY := 0 to LImgHeight do begin
      for LYRepeatCnt := 1 to ARepeat do begin
        LXRepeatCnt := -ARadius;
        while LXRepeatCnt <= LImgWidth + ARadius do begin
          LCalcX := LXRepeatCnt;
          if LCalcX < 0 then begin
            LCalcX := 0;
          end else
          if LCalcX >= LImgWidth then begin
            LCalcX := LImgWidth;
          end;

          LpARGB  := PRGBQuad(LScanStart + LCalcX * LBytesShift);
          LPixel1 := LXRepeatCnt + ARadius;
          LPixel2 := LXRepeatCnt + ARadius - 1;

          LAlpha[LPixel1] := LpARGB^.rgbReserved + LAlpha[LPixel2];
          LRed  [LPixel1] := LpARGB^.rgbRed      + LRed  [LPixel2];
          LGreen[LPixel1] := LpARGB^.rgbGreen    + LGreen[LPixel2];
          LBlue [LPixel1] := LpARGB^.rgbBlue     + LBlue [LPixel2];

          inc(LXRepeatCnt);
        end;

        for LPosX := 0 to LImgWidth do begin
          LpARGB  := PRGBQuad(LScanStart + LPosX * LBytesShift);
          LCalcX  := LPosX + ARadius;
          LPixel1 := LCalcX + ARadius;
          LPixel2 := LCalcX - 1 - ARadius;

          LpARGB^.rgbReserved := ((LAlpha[LPixel1] - LAlpha[LPixel2]) div LDiameter);
          LpARGB^.rgbRed      := ((LRed  [LPixel1] - LRed  [LPixel2]) div LDiameter);
          LpARGB^.rgbGreen    := ((LGreen[LPixel1] - LGreen[LPixel2]) div LDiameter);
          LpARGB^.rgbBlue     := ((LBlue [LPixel1] - LBlue [LPixel2]) div LDiameter);
        end;
      end;
      inc(LScanStart, LDistance);
    end;


    // 計算範囲を(高さ x 半径 x 2 + 1)に拡張
    SetLength(LAlpha, LImgHeight + 1 + (ARadius * 2));
    SetLength(LRed,   LImgHeight + 1 + (ARadius * 2));
    SetLength(LGreen, LImgHeight + 1 + (ARadius * 2));
    SetLength(LBlue,  LImgHeight + 1 + (ARadius * 2));

    for LPosX := 0 to LImgWidth do begin
      for LYRepeatCnt := 1 to ARepeat do begin
        LScanStart  := Integer(LScanLineDst);
        LXRepeatCnt := -ARadius;
        while LXRepeatCnt <= LImgHeight + ARadius do begin
          if (LXRepeatCnt > 0) and (LXRepeatCnt < LImgHeight) then begin
            inc(LScanStart, LDistance);
          end;

          LpARGB  := PRGBQuad(LScanStart + LPosX * LBytesShift);
          LPixel1 := LXRepeatCnt + ARadius;
          LPixel2 := LXRepeatCnt + ARadius - 1;

          LAlpha[LPixel1] := LpARGB.rgbReserved + LAlpha[LPixel2];
          LRed  [LPixel1] := LpARGB.rgbRed      + LRed  [LPixel2];
          LGreen[LPixel1] := LpARGB.rgbGreen    + LGreen[LPixel2];
          LBlue [LPixel1] := LpARGB.rgbBlue     + LBlue [LPixel2];

          inc(LXRepeatCnt);
        end;

        LScanStart := Integer(LScanLineDst);
        for LPosY := 0 to LImgHeight do begin
          LpARGB  := PRGBQuad(LScanStart + LPosX * LBytesShift);
          LCalcY  := LPosY + ARadius;
          LPixel1 := LCalcY + ARadius;
          LPixel2 := LCalcY - 1 - ARadius;

          LpARGB.rgbReserved := ((LAlpha[LPixel1] - LAlpha[LPixel2]) div LDiameter);
          LpARGB.rgbRed      := ((LRed  [LPixel1] - LRed  [LPixel2]) div LDiameter);
          LpARGB.rgbGreen    := ((LGreen[LPixel1] - LGreen[LPixel2]) div LDiameter);
          LpARGB.rgbBlue     := ((LBlue [LPixel1] - LBlue [LPixel2]) div LDiameter);

          inc(LScanStart, LDistance);
        end;
      end;
    end;

    SetLength(LAlpha, 0);
    SetLength(LRed, 0);
    SetLength(LGreen, 0);
    SetLength(LBlue, 0);

    ASrcBmp.Assign(LDstBmp);
  finally
    FreeAndNil(LDstBmp);
  end;

  ASrcBmp.Canvas.Unlock;
end;

//=============================================================================
//  TBitmap をアルファチャンネルの情報を保持してTPngImageに変換
//  戻り値は常に True
//
//  呼び出し側で TPngImage のインスタンスを以下のように生成しておく
//  DstPngImage := TPngImage.CreateBlank(COLOR_RGBALPHA, 8,
//                                       SrcBitmap.Width,SrcBitmap.Height);
//=============================================================================
function ConvertBitmapToPngimage(SrcBitmap: TBitmap;
  DstPngImage: TPngImage): Boolean;
var
  LBmpScanLine   : PRGBQuadArray;
  LPngScanLine   : PRGBTripleArray;
  LpPngARGBQuad  : RGBQUAD;
  LpBmpRGBTriple : RGBTRIPLE;
  LYPos          : Integer;
  LXPos          : Integer;
begin
  Result := True;
  SrcBitmap.Canvas.Lock;
  DstPngImage.Canvas.Lock;

  for LYPos := 0 to SrcBitmap.Height - 1 do begin

    LBmpScanLine := SrcBitmap.ScanLine[LYPos];
    LPngScanLine := DstPngImage.ScanLine[LYPos];

    for LXPos := 0 to SrcBitmap.Width - 1 do begin
      LpPngARGBQuad := LBmpScanLine[LXPos];

      LpBmpRGBTriple.rgbtBlue  := LpPngARGBQuad.rgbBlue;
      LpBmpRGBTriple.rgbtGreen := LpPngARGBQuad.rgbGreen;
      LpBmpRGBTriple.rgbtRed   := LpPngARGBQuad.rgbRed;

      LPngScanLine[LXPos] := LpBmpRGBTriple;
      DstPngImage.AlphaScanline[LYPos]^[LXPos] := LpPngARGBQuad.rgbReserved;
    end;
  end;

  SrcBitmap.Canvas.Unlock;
  DstPngImage.Canvas.Unlock;
end;

end.