Delphi Programming / Object Pascal
サイトのトップページへ リンクのページへ ロゴマーク
[掲載 2017年06月30日] [更新 2022年11月07日]　Delphi サンプルプログラム集
090_ビットマップからアイコン画像ファイルを作成
動作確認等 Windows 10 ビルド 19043 Pro 64 bit + Delphi XE5(UP2) Pro VCL-32
090_Convert_TBitmapTIcon.zip　[4,7 MB]　2022年11月07日版 (EXE 同梱)






各種の画像形式からアイコン画像ファイルを作成


拡張子が .ico のアイコン画像ファイルは，CreateIcon 関数，あるいは CreateIconIndirect 関数を使用して作成できますが， CreateIconIndirect 関数の方が便利です．
CreateIconIndirect 関数の引数は 1 つだけで，IconInfo 構造体です．Delphi では TIconInof レコード型です．この関数はマウスカーソルの作成にも使用します．いずれもビットマップから作成します．
JPEG, GIF, PNG 形式の画像はビットマップ形式の画像に変換できますから，CreateIconIndirect 関数を施用してアイコン画像を作成できることになります．



[備考]
Windows には，解像度，つまり色数を指定してアイコンを作成する関数類はありません．マルチアイコン作施用の関数類もありません．
CreateIcon 関数，または CreateIconIndirect 関数で作成するアイコンは，現在のシステムの標準アイコンです．Windows 7 / 10 の環境では，32 ビットのアルファチャンネル付きのアイコンとなり，透明色が透過状態になります．それ以外の色数のアイコンを作成するには，アイコンヘッダ構造体のメンバと実際のデータを操作する必要があります．
以下の記事に，アイコンヘッダを使用する例があります．



当サイトのアイコン関係の記事へのリンクです．


以下は，アイコンに関する Windows API 関連の記事と，その他の関係記事へのリンクでする





01_ビットマップ画像からアイコン画像を作成


CreateIconIndirect 関数を使用して，アルファチャンネル付きのビットマップ画像からアイコン画像を作成する例です．

 



procedure TForm1.Button1Click(Sender: TObject);
var
  LBitmap     : TBitmap;
  LMaskBitmap : TBitmap;
  LIcon       : TIcon;
  LIconInfo   : TIconInfo;
begin
  Image1.Picture.Assign(nil);

  LBitmap     := TBitmap.Create;
  LMaskBitmap := TBitmap.Create;
  LIcon       := TIcon.Create;
  try
    LBitmap.LoadFromFile('virus.bmp');

    // マスク画像を作成
    // 画像の左下のピクセルの色を透過色とする
    LMaskBitmap.Assign(LBitmap);
    LMaskBitmap.Mask(LMaskBitmap.Canvas.Pixels[0, LMaskBitmap.Height - 1]);

    // TIconInfo レコード型の値をセット
    LIconInfo.fIcon    := True;
    LIconInfo.xHotspot := 0;
    LIconInfo.yHotspot := 0;
    LIconInfo.hbmMask  := LMaskBitmap.Handle;
    LIconInfo.hbmColor := LBitmap.Handle;

    // TIcon 画像を作成
    LIcon.Handle := CreateIconIndirect(LIconInfo );

    Image1.Canvas.Draw(0, 0, LIcon);
  finally
    FreeAndNil(LBitmap);
    FreeAndNil(LMaskBitmap);
    FreeAndNil(LIcon);
  end;
end;


CreateIconIndirect 関数を使用して，アルファチャンネル付きのビットマップ画像からアイコン画像を作成する場合， CreateIconIndirect 関数は，マスク画像を使用しますが，その情報は使用しません．元のビットマップの透明色が透過ピクセルになります．ホットスポットの情報も必要ありません．以下のサンプルでは，マスク画像として，元のビットマップを指定しています．




図1
作成したアイコン画像
  • 作成元は，
    32 ビットのアルファチャンネル付きビットマップ画像

リスト1
アルファチャンネル付きのビットマップ画像からアイコン画像を作成		 
unit Unit1;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes,
  Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.ExtDlgs, Vcl.StdCtrls,
  Vcl.ExtCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Image1: TImage;
    procedure Button1Click(Sender: TObject);
  private
    { Private 宣言 }
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

//=============================================================================
//  TBitmap の画像から TIcon の画像を作成
//
//  TIconInfoレコード型はマウスカーソル作成にも使用する
//  TIconInfo.fIcon がT rue の時はアイコン作成．False の時はマウスカーソル作成
//  TIconInfo.xHotspo,TIconInfo.yHotspot はマウスのホットスポット設定用
//  アイコン作成では使用しない
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  LBitmap   : TBitmap;
  LIcon     : TIcon;
  LIconInfo : TIconInfo;
begin
  Image1.Picture.Assign(nil);

  LBitmap := TBitmap.Create;
  LIcon   := TIcon.Create;
  try
    LBitmap.LoadFromFile('virus.bmp');

    // TIconInfo レコード型の値をセット
    LIconInfo.fIcon    := True;
    LIconInfo.hbmMask  := LBitmap.Handle;
    LIconInfo.hbmColor := LBitmap.Handle;
    // TIcon 画像を作成
    LIcon.Handle := CreateIconIndirect(LIconInfo );

    Image1.Canvas.Draw(0, 0, LIcon);
  finally
    FreeAndNil(LBitmap);
    FreeAndNil(LIcon);
  end;
end;

end.



02_BMP / PNG / GIF 形式の画像からアイコン画像を作成


TBitmap, TPngImage, TGifImage の画像から TIcon の画像を作成するサンプルです．
全て 32 ビットのアルファチャンネル付きのビットマップに変換してからアイコン画像を作成します．2022年現在の時点では，PNG 画像はアルファチャンネル付きが一般的ですので，単純に TBitmap に変換するだけにしています．


[備考]
本サンプルで作成するアイコンは，ピッマップ形式のアイコン画像てず．
CreateIconIndirect 関数では，PNG 形式のアイコンは作成できません．PNG 形式のアイコンは，アイコンヘッダを操作して作成します．




図2
アイコン画像の作成結果
  • 24 ビットのビットマップ画像から作成
  • 左は元のビットマップ画像
  • 右が作成したアイコン画像
  • 作成されるアイコンは 32 ビット色

リスト2
BMP 画像 / PNG 画像 / GIF 画像から TIcon 画像を作成		 
unit Unit1;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes,
  Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.ExtDlgs, Vcl.StdCtrls,
  Vcl.ExtCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Image1: TImage;
    OpenPictureDialog1: TOpenPictureDialog;
    Image2: TImage;
    Label1: TLabel;
    procedure FormCreate(Sender: TObject);
    procedure Button1Click(Sender: TObject);
  private
    { Private 宣言 }
    FInitDir     : string;
    FImgFilePath : string;
  public
    { Public 宣言 }
  end;

  procedure BitmapToAlphaBitmap(TargetBitmap: TBitmap; TransColor: TColor);

var
  Form1: TForm1;

implementation

uses
  Vcl.Imaging.GIFImg,
  Vcl.Imaging.pngimage;

{$R *.dfm}

//=============================================================================
//  フォーム生成時の処理
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
begin
  FInitDir := ExpandFileName('..\Images\');
end;

//=============================================================================
//  TBitmap画像からアイコン画像を作成
//  TBitmap の画像から TIcon の画像を作成
//
//  TIconInfoレコード型はマウスカーソル作成にも使用する
//  TIconInfo.fIcon がT rue の時はアイコン作成．False の時はマウスカーソル作成
//  TIconInfo.xHotspo,TIconInfo.yHotspot はマウスのホットスポット設定用
//  アイコン作成では使用しない
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  LSavePath   : string;
  LFileExt    : string;
  LBitmap     : TBitmap;
  LPngImage   : TPngImage;
  LGifImage   : TGIFImage;
  LTransColor : TColor;
  LIcon       : TIcon;
  LIconInfo   : TIconInfo;
  LBackBitmap : TBitmap;
begin
  OpenPictureDialog1.Filter     := '画像ファイル|*.bmp;*.png;*.gif';
  OpenPictureDialog1.InitialDir := FInitDir;
  if not OpenPictureDialog1.Execute then exit;

  FImgFilePath := OpenPictureDialog1.FileName;
  FInitDir     :=  ExtractFileDir(FImgFilePath);
  LFileExt     := LowerCase(ExtractFileExt(FImgFilePath));

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


  LBitmap     := TBitmap.Create;
  LPngImage  := TPngImage.Create;
  LGifImage  := TGIFImage.Create;

  try
    // TBitmap の画像の場合
    if LFileExt = '.bmp' then begin
      LBitmap.LoadFromFile(FImgFilePath);
      Image1.Canvas.Draw(0, 0, LBitmap);

      LTransColor := LBitmap.Canvas.Pixels[0, LBitmap.Height - 1];
      BitmapToAlphaBitmap(LBitmap, LTransColor);
    end;


    // TPngImage の画像の場合
    if LFileExt = '.png' then begin
      LPngImage.LoadFromFile(FImgFilePath);
      Image1.Canvas.Draw(0, 0, LPngImage);

      // アルファチャンネルの TPngImage 画像を仮定しているので特に処理は不要
      LBitmap.Assign(LPngImage);
    end;


    // TGifImage の画像の場合
    if LFileExt = '.gif' then begin
      LGifImage.LoadFromFile(FImgFilePath);
      Image1.Canvas.Draw(0, 0, LGifImage);

      LTransColor := LGifImage.Bitmap.TransparentColor;
      LBitmap.Assign(LGifImage);
      BitmapToAlphaBitmap(LBitmap, LTransColor);
    end;


    LIcon := TIcon.Create;
    try
      // TIconInfo レコード型の値をセット
      LIconInfo.fIcon    := True;
      LIconInfo.hbmMask  := LBitmap.Handle;
      LIconInfo.hbmColor := LBitmap.Handle;
      // TBitmap 画像から TIcon 画像を作成
      LIcon.Handle := CreateIconIndirect(LIconInfo );

      LSavePath  := '..\Images\Simple_32bit.ico';
      LIcon.SaveToFile(LSavePath);
      Label1.Caption := ExtractFileName(FImgFilePath);

      LBackBitmap := TBitmap.Create;
      try
        // 透過状態の確認用に，背景を市松模様の画像ににする
        LBackBitmap.LoadFromFile(ExpandFileName('..\Images\backTexture_01.bmp'));
        Image2.Canvas.Brush.Bitmap := LBackBitmap;
        Image2.Canvas.FillRect(Image2.ClientRect);
      finally
        FreeAndNil(LBackBitmap);
      end;

      // 作成した TIcon 画像を TImage に描画
      Image2.Canvas.Draw(0, 0, LIcon);
    finally
      FreeAndNil(LIcon);
    end;
  finally
    FreeAndNil(LBitmap);
    FreeAndNil(LPngImage);
    FreeAndNil(LGifImage);
  end;
end;

//-----------------------------------------------------------------------------
//  引数の TBitmap 画像をアルファチャネル付きの TBitmap 画像にする
//  引数の TransColor の色のピクセルを透明色のピクセルにする
//  透明色は ARGB の値が全て 0 のピクセル
//-----------------------------------------------------------------------------
procedure BitmapToAlphaBitmap(TargetBitmap: TBitmap; TransColor: TColor);
type
  TRGBQArray = array [0..4095] of RGBQUAD;
  PRGBQArray = ^TRGBQArray;
var
  LIsSemTrans : Boolean;
  LSrcBitmap  : TBitmap;
  LXPos       : integer;
  LYPos       : Integer;
  LSrcBmpScan : PRGBQArray;
  LDstBmpScan : PRGBQArray;
  LRValue     : Byte;
  LGValue     : Byte;
  LBValue     : Byte;
  LDstAValue : Byte;
  LDstRValue : Byte;
  LDstGValue : Byte;
  LDstBValue : Byte;
begin
  LSrcBitmap := TBitmap.Create;
  try
    TargetBitmap.Canvas.Lock;
    LSrcBitmap.Canvas.Lock;

    LIsSemTrans := False;

    TargetBitmap.AlphaFormat := afIgnored;
    TargetBitmap.PixelFormat := pf32bit;
    LSrcBitmap.Assign(TargetBitmap);

    LRValue := GetRValue(TransColor);
    LGValue := GetGValue(TransColor);
    LBValue := GetBValue(TransColor);

    for LYPos := 0 to TargetBitmap.Height - 1 do begin
      LSrcBmpScan := LSrcBitmap.ScanLine[LYPos];
      LDstBmpScan := TargetBitmap.ScanLine[LYPos];

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

        LDstAValue := LSrcBmpScan[LXPos].rgbReserved;
        LDstRValue := LSrcBmpScan[LXPos].rgbRed;
        LDstGValue := LSrcBmpScan[LXPos].rgbGreen;
        LDstBValue := LSrcBmpScan[LXPos].rgbBlue;

        if (LDstAValue = 0) and (LDstRValue = LRValue)
          and (LDstGValue = LGValue) and (LDstBValue = LBValue) then begin
          LDstBmpScan[LXPos].rgbReserved := 0;
          LDstBmpScan[LXPos].rgbRed      := 0;
          LDstBmpScan[LXPos].rgbGreen    := 0;
          LDstBmpScan[LXPos].rgbBlue     := 0;
        end else begin
          if (LDstAValue > 0) and (LDstAValue < $FF) then begin
            LDstBmpScan[LXPos].rgbReserved := LDstAValue;
            LIsSemTrans := True;
          end else begin
            LDstBmpScan[LXPos].rgbReserved := $FF;
          end;
        end;
      end;
    end;

    // 半透明のビットマップは半透明のままアイコンにするための処理
    if LIsSemTrans then begin
      TargetBitmap.AlphaFormat := afIgnored;
    end else begin
      TargetBitmap.AlphaFormat := afDefined;
    end;
  finally
    TargetBitmap.Canvas.Unlock;
    LSrcBitmap.Canvas.Unlock;
  end;
end;

end.



03_マルチアイコン操作用の TKIcon でアイコン画像ファイルを作成


以下は，TKIcon を使用してアイコンを作成する基本的な例です．マルチアイコン操作用の TKIcon クラスを使用すると，アイコン作成が簡略化できます．
TKIcon ではビットマップ画像または PNG 形式の画像ファイルからアイコン画像を作成します．

操作は単純です．Add メソッドでビットマップを追加するだけです．Add メソッドを実行すると，引数にマスク画像のビットマップのハンドルが代入されますが，本サンプルではこの引数の戻り値は使用していません．格納されるアイコンのサイズとビット深さは，元のビットマップ画像と同じになります．半透明のビットマップもアイコンにできますが，半透明の色は透過色として設定できません．
PNG 形式の画像は，AddFromPng メソッドを使用すると PNG 形式のアイコンとして格納されます．格納されるアイコンのサイズは元のサイズで，32 ビットのアルファチャンネル付きとなります．

TransparentColor の設定がない場合は，左下のピクセルの色を透過色として使用します．PNG 形式の画像の場合は，透明色が透過色となります．

 


procedure TForm1.Button1Click(Sender: TObject);
var
  LBitmap : TBitmap;
  LKIcon  : TKIcon;
begin
  LBitmap := TBitmap.Create;
  LKIcon  := TKIcon.Create;
  try
    LBitmap.LoadFromFile('test.bmp');
    LBitmap.TransparentColor := clRed;
    LKIcon.Add(MakeHandles(LBitmap.Handle, LBitmap.MaskHandle));
    LKIcon.SaveToFile('IconFile.ico');
  finally
    FreeAndNil(LBitmap);
    FreeAndNil(LKIcon);
  end;
end;

[備考 1]
拡張子が .ico のアイコンファイル内に 32 ビット未満のアイコンしかなくても，アイコンファイルのビット深さはシステム既定の値となります．Windows 7 の場合は 32 です．

[備考 2]
アイコンファイルからビットマップ画像を取得するには，TKIcon.CopyToBitmap メソッドを使用します．最初の引数はアイコンのインデックスです．シングルアイコンの場合は 0 にします．2 番目の引数には取得したビットマップを格納する TBitmap 型の変数を指定します．


次のサンプルも，アイコンを 1 しか作成しませんから，単一のアイコン作成と同じです．PNG 形式の画像とビットマップ画像ファイルからアイコン画像ファイルを作成するようにしています．



図3
添付の PNG 画像からアイコン画像ファイル作成
  • 左は変換元の PNG 形式の画像
  • 右が変換したアイコン画像
  • 128 x 128 にリサイズして表示している
    実際の画像サイズは 32 x 32)

図4
24 ビット色のビットマップをアイコン画像に変換

リスト3
マルチアイコン操作用の TKIcon を使用したアイコン画像ファイルの作成		 
unit Unit1;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes,
  Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.ExtDlgs, Vcl.StdCtrls,
  Vcl.ExtCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    OpenPictureDialog1: TOpenPictureDialog;
    Image1: TImage;
    Image2: TImage;
    Label1: TLabel;
    procedure FormCreate(Sender: TObject);
    procedure Button1Click(Sender: TObject);
  private
    { Private 宣言 }
    FInitDir     : string;
    FImgFilePath : string;
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses
  KIcon,
  KGraphics,
  Vcl.Imaging.GIFImg,
  Vcl.Imaging.pngimage;

{$R *.dfm}

//=============================================================================
//  フォーム生成時の処理
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
begin
  FInitDir := ExpandFileName('..\Images\');
  // TPicture で TKIcon を扱えるようにする
  RegisterKIcon;
end;

//=============================================================================
//  ビットマップ画像または PNG 形式画像からアイコン画像ファイルを作成
//  マルチアイコン操作用の TKIcon の機能を使用する方法
//  以下のコードは 1 つだけのマルチアイコンなので単独のアイコンと同じ
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  LSaveFilePath : string;
  LPicture      : TPicture;
  LBitmap       : TBitmap;
  LTempBitmp    : TBitmap;
  LGifImage     : TGIFImage;
  LKIcon        : TKIcon;
  LBackBitmap   : TBitmap;
begin
  OpenPictureDialog1.Filter     := '画像ファイル|*.png;*.bmp;*.gif';
  OpenPictureDialog1.InitialDir := FInitDir;
  if not OpenPictureDialog1.Execute then exit;

  FInitDir :=  ExtractFileDir(OpenPictureDialog1.FileName);


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

  LPicture := TPicture.Create;
  LKIcon   := TKIcon.Create;
  LBitmap  := TBitmap.Create;
  try
    FImgFilePath   := OpenPictureDialog1.FileName;
    LSaveFilePath  := ChangeFileExt(FImgFilePath, '.ico');
    Label1.Caption := ExtractFileName(FImgFilePath);

    LPicture.LoadFromFile(FImgFilePath);

    // アイコンのリストをクリア
    LKIcon.Clear;

    if LPicture.Graphic is TBitmap then begin
      LKIcon.Add(MakeHandles(TBitmap(LPicture.Graphic).Handle,
                             TBitmap(LPicture.Graphic).MaskHandle));
      // 保存
      LKIcon.SaveToFile(LSaveFilePath);
    end else
    if LPicture.Graphic is TPngImage then begin
      LKIcon.AddFromPng(TPngImage(LPicture.Graphic));
      // 保存
      LKIcon.SaveToFile(LSaveFilePath);
    end else
    if LPicture.Graphic is TGIFImage then begin
      LGifImage  := TGIFImage.Create;
      LTempBitmp := TBitmap.Create;
      try
        LGifImage.Assign(TGIFImage(LPicture.Graphic));
        LTempBitmp.Assign(LGifImage);

        // TGIFImage の機能を使用して減色処理
        LBitmap := ReduceColors(LTempBitmp, rmQuantize, dmNearest, 8, 0);

        LBitmap.TransparentColor := LGifImage.Bitmap.TransparentColor;
        LKIcon.Add(MakeHandles(LBitmap.Handle, LBitmap.MaskHandle));
      finally
        FreeAndNil(LGifImage);
        FreeAndNil(LTempBitmp);
      end;
      // 保存
      LKIcon.SaveToFile(LSaveFilePath);
    end else begin
      Exit;
    end;

    //-------------------------------------------------------------------------
    //  保存したので終了であるが
    //  以下は画像の表示のコード
    //  透過状態が分かるように背景に市松模様のビットマップ画像を描画
    //-------------------------------------------------------------------------

    // 透過状態が分かるように背景に市松模様のビットマップ画像を描画
    LBackBitmap := TBitmap.Create;
    try
      LBackBitmap.LoadFromFile(ExpandFileName('..\Images\backTexture_01.bmp'));

      Image1.Canvas.Brush.Bitmap := LBackBitmap;
      Image1.Canvas.FillRect(Image1.ClientRect);

      //読み込んだ画像をTImageに表示
      if LPicture.Graphic is TBitmap then begin
        if TBitmap(LPicture.Graphic).PixelFormat = pf32bit then begin
          TBitmap(LPicture.Graphic).AlphaFormat := afDefined;
        end else begin
          TBitmap(LPicture.Graphic).Transparent := True;
        end;
      end;
      Image1.Canvas.StretchDraw(Rect(0, 0, 128, 128), LPicture.Graphic);

      Image2.Canvas.Brush.Bitmap := LBackBitmap;
      Image2.Canvas.FillRect(Image1.ClientRect);

      // 結果の画像を TImage に表示
      Image2.Canvas.StretchDraw(Rect(0, 0, 128, 128), LKIcon);
    finally
      FreeAndNil(LBackBitmap);
    end;
  finally
    FreeAndNil(LPicture);
    FreeAndNil(LKIcon);
    FreeAndNil(LBitmap);
  end;
end;

end.