'On Error Resume Next
Set ListView1.SmallIcons = ImageList1
Dim hImgSmall As Long
Dim hExeType As Long
Dim imgX As ListImage
Dim ListImgKey As String
Dim itmX As ListItem
If FileName = "" Then Exit Sub
Set itmX = ListView1.ListItems.Add(, , FileName)
If Dir(App.Path + "\temp", vbDirectory) = "" Then MkDir AppPath + "temp"
'生成文件以获得缺省的图标
Open App.Path + "\temp\" + FileName For Output As #1
Close #1
hImgSmall& = SHGetFileInfo(App.Path + "\temp\" + FileName, 0&, shinfo, Len(shinfo), BASIC_SHGFI_FLAGS Or SHGFI_SMALLICON)
ListImgKey = LCase$(StripNulls(shinfo.szTypeName))
If ImageExisting(ListImgKey, ImageList1) = False Then
If vbAddFileItemIcon(hImgSmall) Then
Set imgX = ImageList1.ListImages.Add(, ListImgKey, Picture1.Picture)
End If
End If
itmX.SmallIcon = ImageList1.ListImages(ListImgKey).Key
Set itmX = Nothing
Kill App.Path + "\temp\" + FileName
End Sub
Private Function ImageExisting(Name, IL As ImageList) As Boolean
On Error GoTo er
ImageExisting = False
If IL.ListImages(Name).Key = Name Then ImageExisting = True
Exit Function
er:
ImageExisting = False
End Function
Private Function vbAddFileItemIcon(hImgSmall&) As Long
Dim r As Long
Picture1.Picture = LoadPicture()
r& = ImageList_Draw(hImgSmall&, shinfo.iIcon, Picture1.hDC, 0, 0, ILD_TRANSPARENT)
Picture1.Picture = Picture1.Image
vbAddFileItemIcon& = hImgSmall&
End Function
Private Sub Command1_Click()
AddFile "a.txt" '只需调用AddFile即可添加,文件a.txt是否存在没有关系,但不能带有路径
End Sub
再添加一个Module1,在里面加入下面代码
Public Const BIF_RETURNONLYFSDIRS = &H1
Public Const SHGFI_DISPLAYNAME = &H200
Public Const SHGFI_EXETYPE = &H2000
Public Const SHGFI_SYSICONINDEX = &H4000
Public Const SHGFI_LARGEICON = &H0
Public Const SHGFI_SMALLICON = &H1
Public Const ILD_TRANSPARENT = &H1
Public Const SHGFI_SHELLICONSIZE = &H4
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 Type SHFILEINFO
hIcon As Long
iIcon As Long
dwAttributes As Long
szDisplayName As String * MAX_PATH
szTypeName As String * 80
End Type
Public shinfo As SHFILEINFO
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&, ByVal I&, ByVal hDCDest&, ByVal x&, ByVal y&, ByVal flags&) As Long
Public Function StripNulls(Item As String) As String
Dim pos As Integer
pos = InStr(Item, Chr$(0))
If pos Then Item = Left$(Item, pos - 1)
StripNulls = Item
function TCacheViewXMain.AddIcon(sfLocal,sExt:string):integer;
{AddIcon函数根据sfLocal指定的文件名,将与文件象对应的图标添加到ImageList1
中,并将相应的索引添加到slIcon中
sfLocal 本地文件名,须要获得与该文件相关联的图标局柄}
var
sfi:TSHFileInfo;
i:Integer;
begin
//获得文件的扩展名
i:= slIcon.IndexOf(sExt);
if i>-1 then
Result:=i
else
begin
{获得与sfLocal相关联的文件信息,返回
值保存在sfi中,sfi中的hIcon是文件的关联图标局柄}
SHGetFileInfo(PChar(sExt),FILE_ATTRIBUTE_NORMAL,
sfi, Sizeof(sfi),
(SHGFI_USEFILEATTRIBUTES or SHGFI_ICON or SHGFI_SMALLICON ));
{调用ImageList_AddIcon函数将sfi.hIcon添加到图标列表控件ImageList1中}
i:=ImageList_AddIcon(ImageList1.Handle,sfi.hIcon);
//函数调用成功返回值i为图标在imagelist1中的索引,将slIcon中与索引相同的
//string的值设定为sfLocal的扩展名
if i>-1 then
slIcon.Strings[i]:=sExt;
Result:=i;
end;
end;