VBA獲取文件的圖標(biāo)并顯示在窗體或按鈕上的源碼

'模塊中的代碼
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
'===================================================
'新建一個(gè)窗體，在窗體上添加一個(gè)TextBox用來(lái)輸入文件路徑
'和兩個(gè)picturebox用來(lái)顯示提取到的圖標(biāo)
'以下是窗體中的代碼
Private Sub Text1_Change() '要顯示的圖標(biāo)路徑
Dim hImgSmall As Long
Dim fName As String '驅(qū)動(dòng)器號(hào)、文件夾名、文件名
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中輸入一個(gè)文件路徑就可以看到圖標(biāo)了，但我還要給你說(shuō)的是，你直接輸快捷方式的路徑是不對(duì)的，你要先獲得快捷方式所指向的文件路徑，然后顯示這個(gè)文件路徑的圖標(biāo)才是正確的，挺簡(jiǎn)單的。
還有什么不懂的，你可以來(lái)找我！
暈~
獲得快捷方式的信息更簡(jiǎn)單,看下面:
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