VB and VBA Users Source Code: Extracting the icon associate with a file and displaying in a listview
[
Home
|
Contents
|
Search
|
Reply
| Previous | Next ]
VB/VBA Source Code
Extracting the icon associate with a file and displaying in a listview
By:
Andrew Baker
Email (spam proof):
Email the originator of this post
Date:
Saturday, January 26, 2002
Hits:
1629
Category:
Windows API
Article:
The following code demonstrates how to display files and their associated icons in the same way "Windows Explorer" does. The code in the "Test" routine scans all the files in your C:\ and displays them along with their associated icons in a listview. Private Const MAX_PATH = 260 Private Type GUID Data1 As Long Data2 As Integer Data3 As Integer Data4(7) As Byte End Type Private Type PICTDESC cbSize As Long picType As Long hImage As Long Data1 As Long Data2 As Long End Type Private Type SHFILEINFO hIcon As Long iIcon As Long dwAttributes As Long szDisplayName As String * MAX_PATH szTypeName As String * 80 End Type Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (pPictDesc As PICTDESC, RefIID As GUID, ByVal fPictureOwnsHandle As Long, ppvObj As StdPicture) 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 'Purpose : Retrieves the default associated icon from a file 'Inputs : sFileName The full path and name of the file to retrieve the icon of. 'Outputs : Returns the icon 'Author : Andrew Baker (copyright www.vbusers.com) 'Date : 08/01/2001 20:24 'Notes : 'Revisions : Function FileExtractIcon(sFileName As String) As StdPicture Dim tPic As PICTDESC Dim tIDispatch As GUID Dim oPic As StdPicture Dim hIcon As Long Dim tFileInfo As SHFILEINFO Const SHGFI_ICON = &H100, SHGFI_DISPLAYNAME = &H200 Const SHGFI_TYPENAME = &H400, SHGFI_SMALLICON = &H1 'FYI, file attribute bits Const FILE_ATTRIBUTE_READONLY = &H1, FILE_ATTRIBUTE_HIDDEN = &H2 Const FILE_ATTRIBUTE_SYSTEM = &H4, FILE_ATTRIBUTE_DIRECTORY = &H10 Const FILE_ATTRIBUTE_ARCHIVE = &H20, FILE_ATTRIBUTE_NORMAL = &H80 Const FILE_ATTRIBUTE_TEMPORARY = &H100 On Error Resume Next 'Extract File information Call SHGetFileInfo(sFileName, 0, tFileInfo, Len(tFileInfo), SHGFI_DISPLAYNAME Or SHGFI_TYPENAME Or SHGFI_SMALLICON Or SHGFI_ICON) 'Get the handle to the files icon hIcon = tFileInfo.hIcon 'Initialise type With tPic .cbSize = Len(tPic) .picType = 3 'vbPicTypeIcon .hImage = hIcon End With 'Fill IDispatch Interface ID,{00020400-0000-0000-C000-000000046} With tIDispatch .Data1 = &H20400 .Data4(0) = &HC0 .Data4(7) = &H46 End With 'Get Icon Call OleCreatePictureIndirect(tPic, tIDispatch, 0, oPic) 'Return Icon Set FileExtractIcon = oPic On Error GoTo 0 End Function 'Purpose : Populates a listview with the files in a specified directory 'Inputs : sPath The path to the files ' lvFiles The listview to populate ' imIcons An image list to store the icons ' [sFileFilter] A file filter string 'Outputs : Returns the icon 'Author : Andrew Baker (copyright www.vbusers.com) 'Date : 08/01/2001 20:24 'Notes : eg Call RefreshFiles("C:\", lvFiles, imlFileIcons,"*") 'Revisions : Sub RefreshFiles(ByVal sPath As String, lvFiles As ListView, imIcons As ImageList, Optional sFileFilter As String = "*") Dim oFileIcon As StdPicture, sFileName As String, sFileType As String Dim bAddedImageList As Boolean, lThisColHeader As Long, lWidth As Long On Error Resume Next If Right(sPath, 1) <> "\" Then sPath = sPath & "\" End If sFileName = Dir$(sPath & sFileFilter) lvFiles.View = lvwReport lWidth = lvFiles.Width / 10 For lThisColHeader = lvFiles.ColumnHeaders.Count To 3 Select Case lThisColHeader Case 1 lvFiles.ColumnHeaders.Add , , "File Name", lWidth * 4 Case 2 lvFiles.ColumnHeaders.Add , , "File Size", lWidth * 3 Case 3 lvFiles.ColumnHeaders.Add , , "Last Modified", lWidth * 3 End Select Next lvFiles.ListItems.Clear Do While Len(sFileName) sFileType = Right$(sFileName, 3) If imIcons.ListImages(sFileType).Picture Is Nothing Then 'Find icon associated with file Set oFileIcon = FileExtractIcon(sPath & sFileName) If oFileIcon Is Nothing = False Then 'Add to icon image list imIcons.ListImages.Add , sFileType, oFileIcon If bAddedImageList = False Then 'Initialise listview smallicons lvFiles.SmallIcons = imlFileIcons bAddedImageList = True End If End If End If 'Add item to listview With lvFiles.ListItems.Add(, , sFileName, , sFileType) .SubItems(1) = Format(FileLen(sPath & sFileName) / 1024, "#,##0") & "KB" .SubItems(2) = Format(FileDateTime(sPath & sFileName), "dd/mmm/yyyy hh:mm") End With sFileName = Dir$ Loop End Sub
Terms and Conditions
Support this site
Download a trial version of the Excel Workbook Rebuilder
