|
下の方にある「アイコンのハンドルをピクチャーオブジェクトに変換する」関数の方が貴重だったりするかな。その昔 Visual Basic マガジンに載っていた(と思われる)素晴らしいテクニックである。
Private Const MAX_PATH = 260
Private Type SHFILEINFO
hIcon As Long
iIcon As Long
dwAttributes As Long
szDisplayName As String * MAX_PATH
szTypeName As String * 80
End Type
'ファイルからファイルの情報を取得する
'イメージリストからアイコンのサイズを取得する
'アイコン用に使用されていたメモリを開放する
Private Const SHGFI_LARGEICON = &H0& '大きなアイコン
Private Const SHGFI_SMALLICON = &H1& '小さなアイコン
Private Const SHGFI_SELECTED = &H10000 '反転したアイコン
Private Const SHGFI_SYSICONINDEX = &H4000& 'システムのイメージリストのアイコンのインデックスを取得
Private Const SHGFI_LINKOVERLAY = &H8000& 'ショートカットアイコン
Private Const SHGFI_OPENICON = &H2&
Private Const SHGFI_SHELLICONSIZE = &H4&
Private Const SHGFI_PIDL = &H8&
Private Const SHGFI_ICON = &H100& 'メモリーにアイコンのコピーを作成
Private Const SHGFI_DISPLAYNAME = &H200& 'ファイルの名前
Private Const SHGFI_TYPENAME = &H400& 'ファイルのタイプ名を表示
Private Const SHGFI_ATTRIBUTES = &H800&
Private Const SHGFI_ICONLOCATION = &H1000&
'LowWord value HighWord value ファイルのタイプ
' 0 実行ファイル以外のファイルである
'"NE" or "PE" 3.0, 3.5, or 4.0 Windowsアプリケーアション
'"MZ" 0 MS-DOS .EXE, .COM or .BAT file
'"PE" 0 Win32アプリケーアション
Private Const SHGFI_EXETYPE = &H2000& '実行ファイルタイプ
'アスキーコードとして文字列を表わすための定数
Private Const EXE_WIN16 = &H454E '"NE"
Private Const EXE_DOS16 = &H5A4D '"MZ"
Private Const EXE_WIN32 = &H4550 '"PE"
Private Const EXE_DOS32 = &H4543 '"CE"
Private Type TYPEICON
cbSizeOfStruct As Long
picType As PictureTypeConstants
hIcon As Long
End Type
'クラスIDのWindowsレジストリエントリ
Private Type CLSID
id(15) As Byte
End Type
'ハンドルからピクチャーオブジェクトに変換する
Public Type FILE_VAR_INFO
NormalLrg As Picture
NormalSml As Picture
SelectedLrg As Picture
SelectedSml As Picture
ShortCutLrg As Picture
ShortCutSml As Picture
WidthLrg As Long
WidthSml As Long
HeightLrg As Long
HeightSml As Long
DisplayName As String
FileType As String
ExeType As String
ExeVersion As String
End Type
'-----------------------------------------------------------------------
' 関数名 ： GetIconInfo
' 機能 ： 実行ファイルからファイル情報を取得する
' 引数 ： (in) Filename …実行ファイル名
' (in) udtFvi … FILE_VAR_INFO構造体
' 戻り値 ： 正常終了…True 異常終了…False
' 備考 ：それぞれ SHGetFileInfo を１つずつ呼んでます
'-----------------------------------------------------------------------
Public Function GetFileInfo(ByVal Filename As String, ByRef udtFvi As FILE_VAR_INFO) As Boolean
Dim udtSHFInfo As SHFILEINFO
Dim hImgList As Long
Dim ExeTypeVal As Long
Dim FuncRet As Long
'-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
' 通常アイコン(大)取得
'=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
FuncRet = SHGetFileInfo(ByVal Filename, 0&, udtSHFInfo, Len(udtSHFInfo), _
SHGFI_ICON Or SHGFI_LARGEICON)
If FuncRet = 0 Then Exit Function
Call LoadPictureFromIcon(udtSHFInfo.hIcon, udtFvi.NormalLrg)
'アイコン破棄
Call DestroyIcon(udtSHFInfo.hIcon)
'-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
' 通常アイコン(小)取得
'=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
Call SHGetFileInfo(ByVal Filename, 0&, udtSHFInfo, Len(udtSHFInfo), _
SHGFI_ICON Or SHGFI_SMALLICON)
Call LoadPictureFromIcon(udtSHFInfo.hIcon, udtFvi.NormalSml)
'アイコン破棄
Call DestroyIcon(udtSHFInfo.hIcon)
'-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
' 選択アイコン(大)取得
'=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
Call SHGetFileInfo(ByVal Filename, 0&, udtSHFInfo, Len(udtSHFInfo), _
SHGFI_ICON Or SHGFI_LARGEICON Or SHGFI_SELECTED)
Call LoadPictureFromIcon(udtSHFInfo.hIcon, udtFvi.SelectedLrg)
'アイコン破棄
Call DestroyIcon(udtSHFInfo.hIcon)
'-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
' 選択アイコン(小)取得
'=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
Call SHGetFileInfo(ByVal Filename, 0&, udtSHFInfo, Len(udtSHFInfo), _
SHGFI_ICON Or SHGFI_SMALLICON Or SHGFI_SELECTED)
Call LoadPictureFromIcon(udtSHFInfo.hIcon, udtFvi.SelectedSml)
'アイコン破棄
Call DestroyIcon(udtSHFInfo.hIcon)
'-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
' ショトカットアイコン(大)取得
'=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
Call SHGetFileInfo(ByVal Filename, 0&, udtSHFInfo, Len(udtSHFInfo), _
SHGFI_ICON Or SHGFI_LARGEICON Or SHGFI_LINKOVERLAY)
Call LoadPictureFromIcon(udtSHFInfo.hIcon, udtFvi.ShortCutLrg)
'アイコン破棄
Call DestroyIcon(udtSHFInfo.hIcon)
'-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
' ショトカットアイコン(小)取得
'=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
Call SHGetFileInfo(ByVal Filename, 0&, udtSHFInfo, Len(udtSHFInfo), _
SHGFI_ICON Or SHGFI_SMALLICON Or SHGFI_LINKOVERLAY)
Call LoadPictureFromIcon(udtSHFInfo.hIcon, udtFvi.ShortCutSml)
'アイコン破棄
Call DestroyIcon(udtSHFInfo.hIcon)
'-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
' アイコン(大)サイズ取得
'=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
hImgList = SHGetFileInfo(ByVal Filename, 0&, udtSHFInfo, Len(udtSHFInfo), _
SHGFI_SYSICONINDEX Or SHGFI_LARGEICON)
Call ImageList_GetIconSize(hImgList, udtFvi.WidthLrg, udtFvi.HeightLrg)
'-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
' アイコン(小)サイズ取得
'=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
hImgList = SHGetFileInfo(ByVal Filename, 0&, udtSHFInfo, Len(udtSHFInfo), _
SHGFI_SYSICONINDEX Or SHGFI_SMALLICON)
Call ImageList_GetIconSize(hImgList, udtFvi.WidthSml, udtFvi.HeightSml)
'-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
' 実行ファイル名取得
'=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
Call SHGetFileInfo(ByVal Filename, 0&, udtSHFInfo, Len(udtSHFInfo), SHGFI_DISPLAYNAME)
udtFvi.DisplayName = Left$(udtSHFInfo.szDisplayName, _
InStr(udtSHFInfo.szDisplayName, Chr$(0)) - 1)
'-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
' ファイルタイプ取得
'=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
Call SHGetFileInfo(ByVal Filename, 0&, udtSHFInfo, Len(udtSHFInfo), SHGFI_TYPENAME)
udtFvi.FileType = Left$(udtSHFInfo.szTypeName, _
InStr(udtSHFInfo.szTypeName, Chr$(0)) - 1)
'-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
' ファイルバージョン取得
'=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
Dim LngLowWord As Long '実行ファイルタイプ
Dim LngHighWord As Long
Dim ByteLowWord As Byte 'マイナーバージョン
Dim ByteHighWord As Byte 'メジャーバージョン
ExeTypeVal = SHGetFileInfo(ByVal Filename, 0&, udtSHFInfo, Len(udtSHFInfo), SHGFI_EXETYPE)
LngLowWord = ExeTypeVal And &HFFFF&
LngHighWord = (ExeTypeVal And Not &HFFFF&) \ &HFFFF&
ByteLowWord = LngHighWord And &HFF&
ByteHighWord = (LngHighWord And Not &HFF&) \ &HFF&
'実行ファイルのタイプ
Select Case LngLowWord
Case 0: udtFvi.ExeType = "実行ファイルではありません。"
Case EXE_WIN16: udtFvi.ExeType = "Win16" 'NE
Case EXE_DOS16: udtFvi.ExeType = "DOS" 'MZ
Case EXE_WIN32: udtFvi.ExeType = "Win32" 'PE
Case Else: udtFvi.ExeType = "不明"
End Select
'バージョン
If ByteHighWord Then
udtFvi.ExeVersion = Format$(ByteHighWord, "#") & "." & Format$(ByteLowWord, "00")
End If
GetFileInfo = True
End Function
'-----------------------------------------------------------------------
' 関数名 ： LoadPictureFromIcon
' 機能 ： アイコンのハンドルをピクチャーオブジェクトに変換する
' 引数 ： (in) hIcon … アイコンのハンドル
' (in/out) ObjPicture … ピクチャーオブジェクト
' 戻り値 ： 正常終了…1 エラー…０
'-----------------------------------------------------------------------
Public Function LoadPictureFromIcon(ByVal hIcon As Long, ByRef ObjPicture As Picture) As Long
Dim newIcon As TYPEICON
Dim udtCID As CLSID
If hIcon = 0 Then Exit Function
With newIcon
.cbSizeOfStruct = Len(newIcon)
.picType = vbPicTypeIcon
.hIcon = hIcon
End With
With udtCID
.id(15) = &H46
.id(8) = &HC0
End With
'アイコンのハンドルをオブジェクトに変換
LoadPictureFromIcon = OleCreatePictureIndirect(newIcon, udtCID, 1, ObjPicture)
End Function
ここまで書いたら後は呼ぶだけ。
Private Sub Form_Load()
With Me
.Caption = "メモ帳のファイル情報取得"
.ScaleMode = vbPixels
.AutoRedraw = True
.Width = 160 * Screen.TwipsPerPixelX
.Height = 140 * Screen.TwipsPerPixelY
End With
Dim udtFvi As FILE_VAR_INFO
Dim FileInfoText As String
Dim FuncRet As Boolean
'ファイル情報取得
FuncRet = GetFileInfo(Environ$("WINDIR") & "\notepad.exe", udtFvi)
If Not FuncRet Then Exit Sub
'アイコン表示
Call PaintPicture(udtFvi.NormalLrg, 0, 0)
Call PaintPicture(udtFvi.NormalSml, 33, 0)
Call PaintPicture(udtFvi.SelectedLrg, 50, 0)
Call PaintPicture(udtFvi.SelectedSml, 83, 0)
Call PaintPicture(udtFvi.ShortCutLrg, 100, 0)
Call PaintPicture(udtFvi.ShortCutSml, 133, 0)
'一気に文字列変数に連結(手抜き)
FileInfoText = "サイズ(大)：" & udtFvi.WidthLrg & _
" x " & udtFvi.HeightLrg & vbCrLf
FileInfoText = FileInfoText & "サイズ(小)：" & udtFvi.WidthSml & _
" x " & udtFvi.HeightSml & vbCrLf
FileInfoText = FileInfoText & "種類：" & udtFvi.FileType & vbCrLf
FileInfoText = FileInfoText & "タイプ：" & udtFvi.ExeType & vbCrLf
FileInfoText = FileInfoText & "バージョン：" & udtFvi.ExeVersion
CurrentX = 0: CurrentY = 40
Print FileInfoText
End Sub
|