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;