从文件中解出图标
出处：网络

从任一文件中解出图标。
Thiscodeextractstheiconfromanyfileandsavesitintoaimagelisttobeusedinlistviews,treeviews,andthelike.Itwillextractthewindowsiconforanyfile,doesn'thavetobeadll,icoorexe.
Declare Function SHGetFileInfo Lib "shell32.dll" Alias "SHGetFileInfoA"(ByVal pszPath As Any,ByVal dwFileAttributes As Long,psfi As SHFILEINFO,ByVal cbFileInfo As Long,ByVal uFlags As Long) As Long
Public Declare Function OleCreatePictureIndirect_ Lib "olepro32.dll"(PicDesc As PicBmp,RefIIDAsGUID,_
ByVal fPictureOwnsHandle As Long,IPic As IPicture) As Long
Public Type PicBmp
Size As Long
tType As Long
hBmp As Long
hPal As Long
Reserved As Long
End Type
Public Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End Type
Public Type SHFILEINFO
hicon As Long
iIcon As Long
dwAttributes As Long
szDisplayName As String*260
szTypeName As String*80
End Type
'*****************PUTTHISINYOURFORMCODE*************************
'YOUMUSTMakeaReferenceToStandardOLETypes
'Putacommandbutton,listview,andimagelistonyourform
'andsettheimagelistpropertiesofthelistviewtoimagelist1
'andsettheViewpropertyofthelistviewtolvwList
Public Function GetIconFromFile(FileName As String,IconIndex As Long,UseLargeIcon As Boolean) As Picture
Dim b As SHFILEINFO
Dim retval As Long

retval=SHGetFileInfo(FileName,0,b,Len(b),&H100)

'IPicturerequiresareferenceto"StandardOLETypes."
Dim pic As PicBmp
Dim IPic As IPicture
Dim IID_IDispatch As GUID

With IID_IDispatch
.Data1=&H20400
.Data4(0)=&HC0
.Data4(7)=&H46
End With

With pic
.Size=Len(b)
.tType=vbPicTypeIcon
.hBmp=b.hicon'Handletobitmap.
End With

'CreatePictureobject.
Call OleCreatePictureIndirect(pic,IID_IDispatch,1,IPic)

'ReturnthenewPictureobject.
SetGetIconFromFile=IPic

End Function

Private Sub Command1_Click()

Dim i As Integer
Dim itm As ListItem

ImageList1.ListImages.Add,,GetIconFromFile("c:\anyValidFileorFolder",0,True)

ListView1.Icons=ImageList1

For i=1 To ImageList1.ListImages.Count
Setitm=ListView1.ListItems.Add(,,,,ImageList1.ListImages.Item(i).Index)
Next i
'Questions?Comments?Emailtorgss@inreach.com
End Sub

[返回]

首页 | 设为首页 | 加入收藏 | 关于本站 | 友情链接 | 版权声明