vba读取服务器accsess文件,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