|
これは結構いけてるんじゃない。
拡張子に指定されているアイコンのハンドルは、次のステップを踏む必要がある。
①レジストリよりアイコン指定されているキーを取得する。
例えば、".bmp"拡張子の場合を考えてよう。レジストリエディタを起動してね。起動したら HKEY_CLASSES_ROOT を開いて、".bmp"となっているフォルダを見つけてちょ。そこを開くと
名前 データ
となっているはず。①の作業でこの"Paint.Picture"を取得する。そうしたら、今度は 同HKEY_CLASSES_ROOT 以下のフォルダで "Paint.Picture" を探してみよう。見つけたらその下に "DefaultIcon" というフォルダがあるから開いてね。すると、
名前 データ となっているはず。②の作業でこの"mspaint.exe, 1"を取得する。そうしたら後は簡単。 ExtractIconEx API 関数でアイコンのハンドルを取得するだけ。"mspaint.exe, 1" の "1" は "mspaint.exe" の格納されているアイコンで１番目のものという意味だよ。従って、"mspaint.exe, 1" から "mspaint.exe" と "1" を分離する処理が必要となるね。 ここで、注意することがある。拡張子が実行ファイルであった場合、HKEY_CLASSES_ROOT\exefile\DefaultIcon に格納されている値は "%1" となっており実行ファイルのパスは取得できない。このままだと困るから、実行ファイルは "Shell32.dll"より "EXE"ファイルのアイコンを取得する。これは "Shell32.dll" に格納されておりアイコンのインデックスは２である。これを取得する。また、拡張子が指定されていないファイルがある。この場合は "Shell32.dll" の０番目に格納されているアイコンを取得する。ちなみに、"Shell32.dll" はシステムディレクトリにあるよ。 それじゃあ、コーディング。一気にレッツゴウ!!(死語)
'SYSTEMフォルダを取得する
Private Const HKEY_CLASSES_ROOT = &H80000000
'レジストリキーを開く
'レジストリキーを閉じる
'レジストリからデータを取得する
'システム定義のアイコンの定数
'ファイルからアイコンのハンドルを複数取得する(ExtractIcon)の多機能版
'作成したアイコンを破棄する
Private Const EXE_EXTENSION As String = ".EXE"
Private Const STREMP As String = ""
'---------------------------------------------------------------------
' 関数名 ： GethIconFromExtension
' 機 能 ：拡張子より小さいアイコンのハンドルを取得する
' 引 数 ： (in) Extension … 拡張子("."付)
' 戻り値 ： 取得した小さいアイコンのハンドル エラー時：０
'---------------------------------------------------------------------
Public Function GetSmallhIconFromExtension(ByVal Extension As String) As Long
Dim gIconFilePath As String '拡張子よりアイコンを取得しているファイルのパス
Dim gFilePath As String 'アイコンを取得しているファイルのパス
Dim gIconIndex As String 'アイコンインデックス
Dim hSmallIcon As Long '小さいアイコンのハンドル
Dim ret As Long
Select Case UCase$(Extension)
Case EXE_EXTENSION
'Shell32.dll のパスを取得
gFilePath = GetSystemDir & "\Shell32.dll"
ret = ExtractIconEx(gFilePath, 2, 0, hSmallIcon, 1)
Case Else
'拡張子よりアイコンを取得しているファイルのパスを取得する
gIconFilePath = GetIconPathFromExtension(Extension)
'GetIconPathFromExtension関数でエラーであれば
'SplitFilePath 関数で gFilePath に 空文字列 を格納させる
'ために gIconFilePath = 空文字列 とする
If gIconFilePath = STREMP Then gIconFilePath = STREMP
'ファイルにアイコンが複数指定されている場合があるので","で分離する
Call SplitFilePath(gIconFilePath, 2, gFilePath, gIconIndex)
If gIconIndex <> STREMP Then gIconIndex = Trim$(gIconIndex)
'アイコンが指定されていない
If gFilePath = STREMP Then
'Shell32.dll のパスを取得
gFilePath = GetSystemDir & "\Shell32.dll"
'小さいアイコンのハンドルを取得
ret = ExtractIconEx(gFilePath, 0, 0, hSmallIcon, 1)
'アイコンが指定されている
Else
'小さいアイコンのハンドルを取得
ret = ExtractIconEx(gFilePath, IIf(gIconIndex = STREMP, 0, CLng(gIconIndex)), 0, hSmallIcon, 1)
'エラー時デフォルト()のアイコンハンドルを取得する
If hSmallIcon = 0 Then
'小さいアイコンのハンドルを取得
ret = ExtractIconEx(gFilePath, 0, 0, hSmallIcon, 1)
End If
End If
End Select
GetSmallhIconFromExtension = hSmallIcon
End Function
'---------------------------------------------------------------------
' 関数名 ： GetIconPathFromExtension
' 機能 ：拡張子より拡張子指定されているファイルのパスを取得する
' 引数 ： (in) gSubKey … サブキーの文字列
' 戻り値 ： 拡張子指定されているファイルのパス エラー時：空文字
' 備考 ： 1.HKEY_CLASSES_ROOT より 拡張子に応じたアプリを取得
' 2.①で取得した文字列より、①HKEY_CLASSES_ROOT\DefaultIcon
' より拡張子指定されているファイルのパスを取得する
' 例)C:\PROGRAM FILES\HIDEMARU\Hidemaru.exe,1
' のようにファイルにアイコンが複数指定されている場合、アイコン
' 位置が指定されている
'---------------------------------------------------------------------
Private Function GetIconPathFromExtension(ByVal gSubKey As String) As String
Dim FilePathIncludeIcon As String 'アイコン取得指定されているファイル
'拡張子取得指定されている実行ファイルを取得する
FilePathIncludeIcon = GetKeyTextFromReg(gSubKey)
If FilePathIncludeIcon = STREMP Then Exit Function
'FilePathIncludeIconに指定されているファイルのパスを取得する
GetIconPathFromExtension = GetKeyTextFromReg(FilePathIncludeIcon & "\DefaultIcon")
End Function
'---------------------------------------------------------------------
' 関数名 ： GetKeyTextFromReg
' 機 能 ：レジストリ文字列を取得する
' 引 数 ： (in) gSubKey … サブキーの文字列
' 戻り値 ： 取得した文字列 エラー時：空文字
'---------------------------------------------------------------------
Private Function GetKeyTextFromReg(ByVal gSubKey As String) As String
Dim hRegKey As Long 'キーのハンドル
Dim RegType As Long 'レジストリのデータ型
Dim gExePath As String * 1024 '取得した文字列
If gSubKey = STREMP Then Exit Function
'キーを開く
If RegOpenKey(HKEY_CLASSES_ROOT, gSubKey, hRegKey) = 0 Then
If hRegKey = 0 Then Exit Function
'キーで指定された文字列取得
'名前が(標準)であるときのキーは空文字でよい
If RegQueryValueEx(hRegKey, STREMP, 0, RegType, ByVal gExePath, Len(gExePath)) = 0 Then
GetKeyTextFromReg = strNullCut(gExePath)
End If
End If
'レジストリキーを閉じる
Call RegCloseKey(hRegKey)
End Function
'---------------------------------------------------------------
' 関数名 ： strNullCut
' 機 能 ： 文字列を Chr$(0)[=vbNullChar] まで取得する
' 引 数 ： (in) srcStr … 対象文字列
' 返り値 ：編集された文字列
'---------------------------------------------------------------
Public Function strNullCut(ByVal srcStr As String) As String
Dim NullCharPos As Integer
NullCharPos = InStr(srcStr, Chr$(0))
If NullCharPos = 0 Then
strNullCut = srcStr
Exit Function
End If
strNullCut = Left$(srcStr, NullCharPos - 1)
End Function
'---------------------------------------------------------------
' 関数名 ： SplitFilePath
' 機 能 ： ファイルフルパスをファイル名とフォルダに分離する
' 引 数 ： (in) srcStr … 対象文字列
' (in) strSplitCharID … 分離対象文字ID(０：\、１：/、２：,)
' (in/out) gFolder … 分離されたフォルダ
' (in/out) gFileName … 分離されたファイル名
' 返り値 ： 編集された文字列
' 備考 ： AAAA\BBBB\CCCC.txt であれば gFolder に AAAA\BBBB が
' gFileName に CCCC.txt が返る
'---------------------------------------------------------------
Private Sub SplitFilePath(ByVal srcStr As String, ByVal strSplitCharID As Integer, _
ByRef gFolder As String, ByRef gFileName As String)
Dim srcSplitChar As String '分離対象文字
Dim srcStrLen As Integer '対象文字列のサイズ
Dim gOneChar As String 'Mid$関数より取得した１文字
Dim tmpStr As String '作業用
Dim i As Integer '作業用
gFolder = STREMP
gFileName = STREMP
'"があれば取り除く
If InStr(1, srcStr, Chr$(34)) Then
For i = 1 To Len(srcStr)
gOneChar = Mid$(srcStr, i, 1)
If gOneChar <> Chr$(34) Then
tmpStr = tmpStr & gOneChar
End If
Next i
'"を取った文字列を戻してやる
srcStr = tmpStr
End If
Select Case strSplitCharID
Case 0
srcSplitChar = "\"
Case 1
srcSplitChar = "/"
Case 2
srcSplitChar = ","
End Select
'分離文字が見つからなければそれはファイル
If InStr(1, srcStr, srcSplitChar) = 0 Then
gFolder = STREMP: gFileName = srcStr
Exit Sub
End If
'対象文字列のサイズを取得
srcStrLen = Len(srcStr)
For i = srcStrLen To 1 Step -1
gOneChar = Mid$(srcStr, i, 1)
'分離文字である
If gOneChar = srcSplitChar Then Exit For
gFileName = gOneChar & gFileName
Next i
gFolder = Left$(srcStr, i - 1)
End Sub
'-------------------------------------------------------------------
' 関数名 ： GetSystemDir
' 機 能 ： Systemディレクトリを取得する
' 引 数 ： なし
' 返り値 ： 正常：Systemディレクトリ エラー：空文字列
'-------------------------------------------------------------------
Public Function GetSystemDir() As String
Dim ret As Long
Dim tmpSysDir As String * 256
ret = GetSystemDirectory(tmpSysDir, Len(tmpSysDir))
If ret <> 0 Then
GetSystemDir = Left$(tmpSysDir, InStr(tmpSysDir, Chr$(0)) - 1)
Else
GetSystemDir = STREMP
End If
End Function
ここでは小さいアイコンのハンドルを取得するようにしであるよ。大きいアイコンを取得したければ、 ExtractIconEx API 関数を調べて自分で改造してね。また、SplitFilePath 関数には余分な処理があるけど気にしないでね。 それでは、 Call GetSmallhIconFromExtension(".bmp") と記述(拡張子は適当でよい)して動作確認をしてみてね。また、DrawIconEx API関数で実際に描画させてみてもいいんじゃない。 最後に DestroyIcon API 関数なんだけど、これって作成したアイコンを破棄してくれるやつだよね。Win32 SDKを見ると、 The DestroyIcon function destroys an icon and frees any memory the icon occupied. って書いてあるんだよね。アイコンを破棄し、そしてアイコンが使用したメモリーを解放もしてくれるみたい。アイコンを作成しているわけではないのだけれど、試しに、GetSmallhIconFromExtension で取得したアイコンのハンドル DestroyIcon API関数の引数に与えると１が返った。関数は正常に動作したということはメモリーを解放してくれたということかな。でも破棄はされていない。ここんところがいまいち良く分からん。果たして開放すべきなのであろうか。ちなみに、Visual Basic 増強作戦のサンプルではきちんと開放をしているみたい。Visual Basic 4.0 パワフルテクニック大全集 Vol.1 のサンプルもしかり。ま、関数が正常に動くんで開放しときましょ、という結論でよろしいのではないか。(結構いいかげん) |