VB按文件类型获取图标

作者：xneter 标签：VB

阅读次数：247

声明：
Option Explicit

Private Type TypeIcon
　　cbSize As Long
　　picType As PictureTypeConstants
　　hIcon As Long
End Type

Private Type CLSID
　　id(16) As Byte
End Type

Private Const MAX_PATH = 260
Private Type SHFILEINFO
　　hIcon As Long　　　　　　　　　　　'　out: icon
　　iIcon As Long　　　　　　　　　　　'　out: icon index
　　dwAttributes As Long　　　　　　　 '　out: SFGAO_ flags
　　szDisplayName As String * MAX_PATH '　out: display name (or path)
　　szTypeName As String * 80　　　　　'　out: type name
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

' Convert an icon handle into an IPictureDisp.
Private Function IconToPicture(hIcon As Long) As IPictureDisp
Dim cls_id As CLSID
Dim hRes As Long
Dim new_icon As TypeIcon
Dim lpUnk As IUnknown

　　With new_icon
　　　　.cbSize = Len(new_icon)
　　　　.picType = vbPicTypeIcon
　　　　.hIcon = hIcon
　　End With
　　With cls_id
　　　　.id(8) = &HC0
　　　　.id(15) = &H46
　　End With
　　hRes = OleCreatePictureIndirect(new_icon, _
　　　　cls_id, 1, lpUnk)
　　If hRes = 0 Then Set IconToPicture = lpUnk
End Function

Private Function GetIcon(filename As String, icon_size As Long) As IPictureDisp
Dim index As Integer
Dim hIcon As Long
Dim item_num As Long
Dim icon_pic As IPictureDisp
Dim sh_info As SHFILEINFO

　　SHGetFileInfo filename, 0, sh_info, _
　　　　Len(sh_info), SHGFI_ICON + icon_size
　　hIcon = sh_info.hIcon
　　Set icon_pic = IconToPicture(hIcon)
　　Set GetIcon = icon_pic
End Function

调用：

小图标：
Picture1.Picture=GetIcon(filename,SHGFI_SMALLICON)
大图标：
Picture1.Picture=GetIcon(filename,SHGFI_LARGEICON)