VB提取文件图标到StdPicture

Option Explicit
Private Type PICTDESC
cbSizeofStruct As Long
xExt As Long
yExt As Long
hImage As Long
picType As Long
End Type
Public Enum IconExtractEnum
[SIZE_16] = 0
[SIZE_32] = 1
End Enum
Private Const MAX_PATH = 260
Private Type SHFILEINFO
hIcon As Long
iIcon As Long
dwAttributes As Long 'out: SFGAO_ flags
szDisplayName As String * MAX_PATH
szTypeName As String * 80
End Type
Private Type TypeIcon
cbSize As Long
picType As PictureTypeConstants
hIcon As Long
End Type
Private Type PicBmp
Size As Long
tType As Long
hBmp As Long
hPal As Long
Reserved As Long
End Type
Private Type CLSID
id((123)) As Byte
End Type
Private Declare Function OleCreatePictureIndirect Lib “oleaut32.dll” (pDicDesc As TypeIcon, riid As CLSID, ByVal fown As Long, lpUnk As Object) As Long
Private Declare Function SHGetFileInfo Lib “shell32.dll” Alias “SHGetFileInfoA” (ByVal pszPath As String, ByVal dwFileAttributes As Long, psfi As SHFILEINFO, ByVal cbFileInfo As Long, ByVal uFlags As Long) As Long
Private Const SHGFI_ICON = &H100
Private Const SHGFI_LARGEICON = &H0
Private Const SHGFI_SMALLICON = &H1

Dim Pic As New StdPicture

Private Function GetFileIcon(ByVal sFileName As String, ByVal IconSize As IconExtractEnum) As StdPicture
Dim SHinfo As SHFILEINFO, mTYPEICON As TypeIcon, mCLSID As CLSID, hIcon As Long, lFlag As Long
If IconSize = [SIZE_16] Then lFlag = SHGFI_SMALLICON Else lFlag = SHGFI_LARGEICON
If Right(sFileName, 1) <> “” Then sFileName = sFileName & “”
Call SHGetFileInfo(sFileName, 0, SHinfo, Len(SHinfo), SHGFI_ICON + lFlag)
With mTYPEICON
.cbSize = Len(mTYPEICON)
.picType = vbPicTypeIcon
.hIcon = SHinfo.hIcon
End With
With mCLSID
.id(8) = &HC0
.id(15) = &H46
End With
Call OleCreatePictureIndirect(mTYPEICON, mCLSID, 1, GetFileIcon)
End Function

Private Sub Form_Load()
Set Pic = GetFileIcon(“文件绝对路径”, SIZE_32)
Me.AutoRedraw = True
Me.Picture = Pic
End Sub