Question

vb 提取exe图标 并加载到imagelist1

Answer 1

这是我以前写的一个程序的模块部分，可以获取绝大多数文件的图标，包括文件夹和磁盘驱动器的图标。答案仅供参考。程序正常运行需要新建一个窗体，在窗体上添加一个图片框控件，命名为picInvisible。添加一个ImageList控件，名称默认。窗体的代码编辑窗口输入以下代码：

Option Explicit
Private Const SHGFI_DISPLAYNAME = &H200
Private Const SHGFI_EXETYPE = &H2000
Private Const SHGFI_SYSICONINDEX = &H4000 ' system icon index
Private Const SHGFI_LARGEICON = &H0 ' large icon
Private Const SHGFI_SMALLICON = &H1 ' small icon
Private Const ILD_TRANSPARENT = &H1 ' display transparent
Private Const SHGFI_SHELLICONSIZE = &H4
Private Const SHGFI_TYPENAME = &H400
Private Const BASIC_SHGFI_FLAGS = SHGFI_TYPENAME Or _
SHGFI_SHELLICONSIZE Or SHGFI_SYSICONINDEX Or _
SHGFI_DISPLAYNAME Or SHGFI_EXETYPEPrivate 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 Declare Function ImageList_Draw Lib "comctl32.dll" _
(ByVal himl As Long, _
ByVal i As Long, _
ByVal hDCDest As Long, _
ByVal x As Long, _
ByVal y As Long, _
ByVal flags As Long) As Long

Private Declare Function SHGetFileInfo Lib "shell32.dll" _
Alias "SHGetFileInfoA" _
(ByVal pszPath As String, _
ByVal dwFileAttributes As Long, _
psfi As SHFILEINFO, _
ByVal cbSizeFileInfo As Long, _
ByVal uFlags As Long) As Long

Private shinfo As SHFILEINFO
Private hFile As Long

Function StripNulls(ByVal str As String) As String
If InStr(1, str, Chr(0)) Then
StripNulls = Left(str, InStr(1, str, Chr(0)) - 1)
Else
StripNulls = str
End If
End Function

Sub InitPicBox(ByRef pic As PictureBox)
With pic
.AutoRedraw = True
.AutoSize = True
.Appearance = 0
' .Visible = False
End With
End Sub

Sub GetIcon(ByVal FilePath As String)
'获取文件图标句柄
hFile = SHGetFileInfo(FilePath, 0&, shinfo, Len(shinfo), _
BASIC_SHGFI_FLAGS Or SHGFI_SMALLICON)

If hFile Then
Call DrawIcon(picInvisible) '绘制图标
Call AddIconToImageList(ImageList1)
Else
MsgBox "提取文件图标出错" & vbCrLf & Err.LastDllError & " " _
& Error(Err.LastDllError)
End If
End Sub

Sub DrawIcon(ByRef pic As PictureBox)
pic.Picture = LoadPicture() '清空上次图像
Call ImageList_Draw(hFile, shinfo.iIcon, pic.hDC, 0, 0, ILD_TRANSPARENT)
pic.Picture = pic.Image
End Sub

Sub AddIconToImageList(ByRef imgList As ImageList)
Dim imgX As ListImage
Dim strKey As String
strKey = Trim(LCase(StripNulls(shinfo.szDisplayName)))
Set imgX = imgList.ListImages.Add(, strKey, picInvisible.Image)
Set imgX = Nothing
End Sub

Private Sub Form_Load()
Call InitPicBox(picInvisible)
End Sub
要获取指定文件的图标只需要把要获取图标的文件的路径作为参数传给GetIcon过程即可，赶快测试下吧！
注：程序没有给出错误处理编码，这是需要优化的地方之一。此外，你要是有兴趣的话可以把它写成一个类模块，这样以后开发需要类似功能的软件时直接添加类模块调用就行了。