VBA获取文件的图标并显示在窗体或按钮上的源码

'模块中的代码
Option Explicit
Public Const SHGFI_DISPLAYNAME = &H200
Public Const SHGFI_EXETYPE = &H2000
Public Const SHGFI_LARGEICON = &H0
Public Const SHGFI_SHELLICONSIZE = &H4
Public Const SHGFI_SMALLICON = &H1
Public Const SHGFI_SYSICONINDEX = &H4000
Public Const SHGFI_TYPENAME = &H400
Public Const BASIC_SHGFI_FLAGS = SHGFI_TYPENAME Or SHGFI_SHELLICONSIZE Or SHGFI_SYSICONINDEX Or SHGFI_DISPLAYNAME Or SHGFI_EXETYPE
Public Const MAX_PATH = 260
Public Const ILD_TRANSPARENT = &H1
Public Type SHFILEINFO
hIcon As Long
iIcon As Long
dwAttributes As Long
szDisplayName As String * MAX_PATH
szTypeName As String * 80
End Type
Public 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
Public 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
Public shinfo As SHFILEINFO
Public Const SHGFI_USEFILEATTRIBUTES = &H10
Public Const SHGFI_ICON = &H100
'===================================================
'新建一个窗体，在窗体上添加一个TextBox用来输入文件路径
'和两个picturebox用来显示提取到的图标
'以下是窗体中的代码
Private Sub Text1_Change() '要显示的图标路径
Dim hImgSmall As Long
Dim fName As String '驱动器号、文件夹名、文件名
Dim r As Long
Dim hImgLarge As Long
Dim Info1 As String, Info2 As String
fName = Text1.Text
hImgSmall& = SHGetFileInfo(fName$, 0&, shinfo, Len(shinfo), SHGFI_ICON Or SHGFI_SMALLICON Or SHGFI_SYSICONINDEX Or SHGFI_USEFILEATTRIBUTES)
hImgLarge& = SHGetFileInfo(fName$, 0&, shinfo, Len(shinfo), SHGFI_ICON Or BASIC_SHGFI_FLAGS Or SHGFI_SYSICONINDEX Or SHGFI_USEFILEATTRIBUTES)
Info1 = Left$(shinfo.szDisplayName, InStr(shinfo.szDisplayName, Chr$(0)) - 1)
Info2 = Left$(shinfo.szTypeName, InStr(shinfo.szTypeName, Chr$(0)) - 1)
Debug.Print Info1; Info2
Picture1.Picture = LoadPicture()
Picture1.AutoRedraw = True
Picture2.Picture = LoadPicture()
Picture2.AutoRedraw = True
r = ImageList_Draw(hImgSmall&, shinfo.iIcon, Picture1.hDC, 0, 0, ILD_TRANSPARENT)
r = ImageList_Draw(hImgLarge&, shinfo.iIcon, Picture2.hDC, 3, 3, ILD_TRANSPARENT)
Set Picture1.Picture = Picture1.Image
Set Picture2.Picture = Picture2.Image
End Sub
有了上面的代码,你在Text1中输入一个文件路径就可以看到图标了，但我还要给你说的是，你直接输快捷方式的路径是不对的，你要先获得快捷方式所指向的文件路径，然后显示这个文件路径的图标才是正确的，挺简单的。
还有什么不懂的，你可以来找我！
晕~
获得快捷方式的信息更简单,看下面:
Option Explicit
'注意要引用：Microsoft Shell Controls And Automation
Private Sub Command1_Click()
Dim FolderPath As String
Dim ShortcutName As String
Dim WorkDir As String
Dim Arguments As String, Description As String
Dim IconIdx As Long, ShowCommand As Long
FolderPath = "C:\Documents and Settings\Administrator\桌面" '快捷方式所在的目录
ShortcutName = "ToolBox.exe.lnk" '快捷方式的文件名,注意要加lnk
Dim IconFile As String
Call GetShellLinkInfo(FolderPath, ShortcutName, WorkDir, Arguments, Description, IconFile, IconIdx, ShowCommand)
End Sub
Private Sub GetShellLinkInfo(ByVal FolderPath As String, ByVal ShortcutName As String, WorkDir As String, _
Arguments As String, Description As String, IconFile As String, IconIdx As Long, _
ShowCommand As Long)
Dim mShell As Shell, mFile As FolderItem, mFolder As Folder
Dim lnk As ShellLinkObject, i As Long
Set mShell = New Shell
Set mFolder = mShell.NameSpace(FolderPath)
On Error Resume Next
Set mFile = mFolder.Items.Item(ShortcutName)
If Err Then
MsgBox ShortcutName & " is inaccessable!"
Err.Clear
GoTo exit_sub
Else
If mFile.IsLink Then
Set lnk = mFile.GetLink
WorkDir = lnk.WorkingDirectory
Arguments = lnk.Arguments
Description = lnk.Description
IconIdx = lnk.GetIconLocation(IconFile)
ShowCommand = lnk.ShowCommand
MsgBox "Name: " & mFile.Name & vbCrLf & _
"Description: " & lnk.Description & vbCrLf & _
"Path: " & lnk.Path & vbCrLf & _
"WorkingDirectory: " & lnk.WorkingDirectory & vbCrLf, vbInformation
Else
MsgBox ShortcutName & " is not a shortcut!", vbInformation
End If
End If
exit_sub:
Set lnk = Nothing
Set mFile = Nothing
Set mFolder = Nothing
Set mShell = Nothing
End Sub