PerlからWin32 apiを使ってみた(アイコンの取り出し)

1ヶ月位前にMSDNのサイトに、よく使われるWindows APIリストを集めたページが公開されました。
Windows API リスト: Windows API、Win32 API、Win32API | MSDN

頭から眺めて何か面白そうなAPIは無いかなと思っていると、ど頭の「アイコン」カテゴリが少し気になったので
Win32apiを叩いて、exeファイルからアイコンを取り出すperlスクリプトを書くことにしました。

#!perl
use strict;
use warnings;
use Win32::API;
use Imager;

Win32::API::Struct->typedef( ICONINFO => qw {
	INT  fIcon;
	INT xHotspot;
	INT yHotspot;
	LONG hbmMask;
	LONG hbmColor;
});

Win32::API::Struct->typedef( BITMAP => qw {
  LONG   bmType;
  LONG   bmWidth;
  LONG   bmHeight;
  LONG   bmWidthBytes;
  WORD   bmPlanes;
  WORD   bmBitsPixel;
  LPVOID bmBits;
});

my $ExtractIcon = new Win32::API( 'shell32.dll', 'ExtractIcon', 'NPI', 'N' ) or die;
my $GetIconInfo = new Win32::API( 'user32.dll', 'GetIconInfo',  'NS',  'I' ) or die;
my $GetObject1   = new Win32::API( 'gdi32.dll', 'GetObject',     'NIP', 'I' ) or die;
my $GetObject2   = new Win32::API( 'gdi32.dll', 'GetObject',     'NIS', 'I' ) or die;
my $GetBitmapBits = new Win32::API( 'gdi32.dll', 'GetBitmapBits', 'NNP', 'I' ) or die;

#ExtractIconでexeファイルから0番目のアイコンハンドルを取得
my $hicon = $ExtractIcon->Call($$, 'C:/EXCEL.EXE', 0) or die;

#ICONINFO構造体を用意して、GetIconInfoでアイコンの情報を取得
my $piconinfo = Win32::API::Struct->new('ICONINFO') or die;
$GetIconInfo->Call( $hicon, $piconinfo )or die;

#GetObjectの第3引数に0を指定して必要なバッファサイズを取得
my $size = $GetObject1->Call( $piconinfo->{hbmColor}, 0, 0 );

#BITMAP構造体を用意して、GetObjectでアイコンのビットマップ情報を取得
my $bmp = Win32::API::Struct->new('BITMAP') or die;
$GetObject2->Call( $piconinfo->{hbmColor}, $size, $bmp );

#上で得たビットマップ情報から、必要なバッファサイズを計算
my $bmp_size = ($bmp->{bmBitsPixel} * $bmp->{bmHeight} * $bmp->{bmWidth})/4;
my $bmp2 = ' ' x $bmp_size;

#GetBitmapBitsでビットマップビット列を取得
$GetBitmapBits->Call($piconinfo->{hbmColor}, $bmp_size, $bmp2 );

#後はImagerを使って書き出す
my $newimg = Imager->new(xsize => $bmp->{bmWidth}, ysize => $bmp->{bmHeight} );

for( my $i=0; '' ne $bmp2; $i++ ){
	my $pix = join( '', unpack("H8", $bmp2) );
	$newimg->setpixel(x => $i % $bmp->{bmWidth}, y => int($i / $bmp->{bmWidth}), color => $pix);
	my $del = quotemeta pack("H8", $pix);
	$bmp2 =~ s/^$del//;
}
$newimg->write(file =>"test.bmp") or die;

そして、無事アイコンを取り出すことが出来ました。
めでたしめでたし。