Solved

Retreiving filetype icons

Posted on 1998-11-20
6
254 Views
Last Modified: 2012-05-04
I want to get a hold of the icon for a specific filetype.
For example if the file extension was 'BMP' I want to get
the icon/bitmap that is used within explorer to represent
this type of file.

I suspect that I will have to search the registry for the
association and then extract an icon from the file viewer
app.

Does anyone have any code that does this, preferably VB ?

Thanks.

Andrew....
0
Comment
Question by:a_murray
  • 4
  • 2
6 Comments
 
LVL 14

Accepted Solution

by:
waty earned 280 total points
ID: 1445891
Use the following class

' *********************************************************************
'  Copyright (C)1995-98 Karl E. Peterson, All Rights Reserved
'  http://www.mvps.org/vb
' *********************************************************************
'  Warning: This computer program is protected by copyright law and
'  international treaties. Unauthorized reproduction or distribution
'  of this program, or any portion of it, may result in severe civil
'  and criminal penalties, and will be prosecuted to the maximum
'  extent possible under the law.
' *********************************************************************
Option Explicit
'
' API declarations
'
Private Declare Function GetFullPathName Lib "kernel32" Alias "GetFullPathNameA" (ByVal lpFileName As String, ByVal nBufferLength As Long, ByVal lpBuffer As String, lpFilePart As Long) As Long
Private Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal nBufferLength As Long) As Long
Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
Private Declare Function FileTimeToLocalFileTime Lib "kernel32" (lpFileTime As FILETIME, lpLocalFileTime As FILETIME) As Long
Private Declare Function FileTimeToSystemTime Lib "kernel32" (lpFileTime As FILETIME, lpSystemTime As SYSTEMTIME) As Long
Private Declare Function GetCompressedFileSize Lib "kernel32" Alias "GetCompressedFileSizeA" (ByVal lpFileName As String, lpFileSizeHigh As Long) 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
'
' API constants.
'
Private Const MAX_PATH = 260
Private Const INVALID_HANDLE_VALUE = -1
'
' File attribute constants.
'
Private Const FILE_ATTRIBUTE_READONLY = &H1
Private Const FILE_ATTRIBUTE_HIDDEN = &H2
Private Const FILE_ATTRIBUTE_SYSTEM = &H4
Private Const FILE_ATTRIBUTE_DIRECTORY = &H10
Private Const FILE_ATTRIBUTE_ARCHIVE = &H20
Private Const FILE_ATTRIBUTE_NORMAL = &H80
Private Const FILE_ATTRIBUTE_TEMPORARY = &H100
Private Const FILE_ATTRIBUTE_COMPRESSED = &H800
'
' SHGetFileInfo constants.
'
Private Const SHGFI_ICON = &H100                         '  get icon
Private Const SHGFI_DISPLAYNAME = &H200                  '  get display name
Private Const SHGFI_TYPENAME = &H400                     '  get type name
Private Const SHGFI_ATTRIBUTES = &H800                   '  get attributes
Private Const SHGFI_ICONLOCATION = &H1000                '  get icon location
Private Const SHGFI_EXETYPE = &H2000                     '  return exe type
Private Const SHGFI_SYSICONINDEX = &H4000                '  get system icon index
Private Const SHGFI_LINKOVERLAY = &H8000                 '  put a link overlay on icon
Private Const SHGFI_SELECTED = &H10000                   '  show icon in selected state
Private Const SHGFI_LARGEICON = &H0                      '  get large icon
Private Const SHGFI_SMALLICON = &H1                      '  get small icon
Private Const SHGFI_OPENICON = &H2                       '  get open icon
Private Const SHGFI_SHELLICONSIZE = &H4                  '  get shell size icon
Private Const SHGFI_PIDL = &H8                           '  pszPath is a pidl
Private Const SHGFI_USEFILEATTRIBUTES = &H10             '  use passed dwFileAttribute
'
' API structures.
'
Private Type FILETIME
   dwLowDateTime As Long
   dwHighDateTime As Long
End Type

Private Type WIN32_FIND_DATA
   dwFileAttributes As Long
   ftCreationTime As FILETIME
   ftLastAccessTime As FILETIME
   ftLastWriteTime As FILETIME
   nFileSizeHigh As Long
   nFileSizeLow As Long
   dwReserved0 As Long
   dwReserved1 As Long
   cFileName As String * MAX_PATH
   cAlternate As String * 14
End Type

Private Type SYSTEMTIME
   wYear As Integer
   wMonth As Integer
   wDayOfWeek As Integer
   wDay As Integer
   wHour As Integer
   wMinute As Integer
   wSecond As Integer
   wMilliseconds As Integer
End Type

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
'
' Member variables.
'
Private m_PathName As String
Private m_Name As String
Private m_Path As String
Private m_Extension As String
Private m_DisplayName As String
Private m_TypeName As String
Private m_hIcon As Long
Private m_PathNameShort As String
Private m_NameShort As String
Private m_PathShort As String
Private m_FileExists As Boolean
Private m_PathExists As Boolean
Private m_FileSize As Long
Private m_FileSizeHigh As Long
Private m_CompFileSize As Long
Private m_CompFileSizeHigh As Long
Private m_Attributes As Long
Private m_tmCreation As Double
Private m_tmAccess As Double
Private m_tmWrite As Double

' ********************************************
'  Initialize and Terminate
' ********************************************
Private Sub Class_Initialize()
   '
   ' All member variables can be left to defaults.
   '
End Sub

Private Sub Class_Terminate()
   '
   ' No special cleanup required.
   '
End Sub

' ********************************************
'  Public Properties
' ********************************************
Public Property Let FullPathName(ByVal NewVal As String)
   Dim Buffer As String
   Dim nFilePart As Long
   Dim nRet As Long
   '
   ' Retrieve fully qualified path/name specs.
   '
   Buffer = Space(MAX_PATH)
   nRet = GetFullPathName(NewVal, Len(Buffer), Buffer, nFilePart)
   If nRet Then
      m_PathName = Left(Buffer, nRet)
      Refresh
   End If
End Property

Public Property Get FullPathName() As String
   ' Returns fully-qualified path/name spec.
   FullPathName = m_PathName
End Property

Public Property Get FileName() As String
   ' Returns filename only.
   FileName = m_Name
End Property

Public Property Get FilePath() As String
   ' Returns fully-qualified pathname only.
   FilePath = m_Path
End Property

Public Property Get FileExtension() As String
   ' Returns the file's extension only.
   FileExtension = m_Extension
End Property

Public Property Get ShortPathName() As String
   ' Returns fully-qualified *short* path/name spec.
   ShortPathName = m_PathNameShort
End Property

Public Property Get ShortName() As String
   ' Returns *short* filename only.
   ShortName = m_NameShort
End Property

Public Property Get ShortPath() As String
   ' Returns *short* fully-qualified pathname only.
   ShortPath = m_PathShort
End Property

Public Property Get DisplayName() As String
   ' Returns the "display" name for the file, not necessarily
   ' proper-cased, but as Explorer shows it.
   DisplayName = m_DisplayName
End Property

Public Property Get TypeName() As String
   ' Returns the string that describes the file's type.
   TypeName = m_TypeName
End Property

Public Property Get FileExists() As Boolean
   ' Returns whether file exists.
   FileExists = m_FileExists
End Property

Public Property Get PathExists() As Boolean
   ' Returns whether path exists.
   PathExists = m_PathExists
End Property

Public Property Get FileSize() As Long
   ' Return size of file.
   FileSize = m_FileSize
End Property

Public Property Get FileSizeHigh() As Long
   ' Returns high dword of filesize to support files > 2Gb.
   FileSizeHigh = m_FileSizeHigh
End Property

Public Property Get CompressedFileSize() As Long
   ' Return actual size of file.
   CompressedFileSize = m_CompFileSize
End Property

Public Property Get CompressedFileSizeHigh() As Long
   ' Returns high dword of actual filesize to support files > 2Gb.
   CompressedFileSizeHigh = m_CompFileSizeHigh
End Property

Public Property Get CreationTime() As Double
   ' Returns date/time of file creation.
   CreationTime = m_tmCreation
End Property

Public Property Get LastAccessTime() As Double
   ' Returns date/time of last access.
   LastAccessTime = m_tmAccess
End Property

Public Property Get ModifyTime() As Double
   ' Returns date/time of last write.
   ModifyTime = m_tmWrite
End Property

Public Property Get Attributes() As Long
   ' Returns entire set of attribute flags.
   Attributes = m_Attributes
End Property

Public Property Get attrReadOnly() As Boolean
   ' Returns whether file has ReadOnly attribute.
   attrReadOnly = (m_Attributes And FILE_ATTRIBUTE_READONLY)
End Property

Public Property Get attrHidden() As Boolean
   ' Returns whether file has Hidden attribute.
   attrHidden = (m_Attributes And FILE_ATTRIBUTE_HIDDEN)
End Property

Public Property Get attrSystem() As Boolean
   ' Returns whether file has System attribute.
   attrSystem = (m_Attributes And FILE_ATTRIBUTE_SYSTEM)
End Property

Public Property Get attrArchive() As Boolean
   ' Returns whether file has Archive attribute.
   attrArchive = (m_Attributes And FILE_ATTRIBUTE_ARCHIVE)
End Property

Public Property Get attrTemporary() As Boolean
   ' Returns whether file has Temporary attribute.
   attrTemporary = (m_Attributes And FILE_ATTRIBUTE_TEMPORARY)
End Property

Public Property Get attrCompressed() As Boolean
   ' Returns whether file has Compressed attribute.
   attrCompressed = (m_Attributes And FILE_ATTRIBUTE_COMPRESSED)
End Property

Public Property Get hIcon() As Long
   ' Returns handle to display icon.
   hIcon = m_hIcon
End Property

' ********************************************
'  Public Methods
' ********************************************
Public Sub Refresh()
   Dim hSearch As Long
   Dim wfd As WIN32_FIND_DATA
   Dim Buffer As String
   Dim nRet As Long
   Dim i As Long
   Dim sfi As SHFILEINFO
   '
   ' Check for existence of file.
   '
   hSearch = FindFirstFile(m_PathName, wfd)
   If hSearch <> INVALID_HANDLE_VALUE Then
      Call FindClose(hSearch)
      '
      ' Assign file data to member variables.
      '
      m_FileExists = True
      m_PathExists = True
      m_FileSize = wfd.nFileSizeLow
      m_FileSizeHigh = wfd.nFileSizeHigh
      m_Attributes = wfd.dwFileAttributes
      m_tmCreation = FileTimeToDouble(wfd.ftCreationTime, True)
      m_tmAccess = FileTimeToDouble(wfd.ftLastAccessTime, True)
      m_tmWrite = FileTimeToDouble(wfd.ftLastWriteTime, True)
      '
      ' Assign file/path data to member variables.
      '
      m_Name = TrimNull(wfd.cFileName)
      For i = Len(m_PathName) To 1 Step -1
         If Mid(m_PathName, i, 1) = "\" Then
            m_Path = ProperCasePath(Left(m_PathName, i))
            If Right(m_Path, 1) <> "\" Then m_Path = m_Path & "\"
            Exit For
         End If
      Next i
      m_PathName = m_Path & m_Name
      '
      ' Extract extension from filename.
      '
      If InStr(m_Name, ".") Then
         For i = Len(m_Name) To 1 Step -1
            If Mid(m_Name, i, 1) = "." Then
               m_Extension = Mid(m_Name, i + 1)
               Exit For
            End If
         Next i
      Else
         m_Extension = ""
      End If
      '
      ' Short name same as long, if cAlternate element empty.
      '
      If InStr(wfd.cAlternate, vbNullChar) = 1 Then
         m_NameShort = UCase(m_Name)
      Else
         m_NameShort = TrimNull(wfd.cAlternate)
      End If
      '
      ' Retrieve short path name.
      '
      Buffer = Space(MAX_PATH)
      nRet = GetShortPathName(m_PathName, Buffer, Len(Buffer))
      If nRet Then
         m_PathNameShort = Left(Buffer, nRet)
         m_PathShort = Left(m_PathNameShort, Len(m_PathNameShort) - Len(m_NameShort))
      End If
      '
      ' Retrieve compressed size.
      '
      m_CompFileSize = GetCompressedFileSize(m_PathName, m_CompFileSizeHigh)
      '
      ' Get icon and descriptive text.
      '
      nRet = SHGetFileInfo(m_PathName, 0&, sfi, Len(sfi), _
             SHGFI_ICON Or SHGFI_DISPLAYNAME Or SHGFI_TYPENAME)
      m_DisplayName = TrimNull(sfi.szDisplayName)
      m_TypeName = TrimNull(sfi.szTypeName)
      m_hIcon = sfi.hIcon
      '
      ' Confirm displayable typename.
      '
      If Trim(m_TypeName) = "" Then
         m_TypeName = Trim(UCase(m_Extension) & " File")
      End If
   Else
      '
      ' Assign applicable data to member variables.
      '
      m_FileExists = False
   End If
End Sub

Public Function FormatFileDate(ByVal dt As Double) As String
   FormatFileDate = Format(dt, "long date") & " " & _
                    Format(dt, "long time")
End Function

Public Function FormatFileSize(ByVal Size As Long) As String
   Dim sRet As String
   Const KB& = 1024
   Const MB& = KB * KB
   ' Return size of file in kilobytes.
   If Size < KB Then
      sRet = Format(Size, "#,##0") & " bytes"
   Else
      Select Case Size \ KB
         Case Is < 10
            sRet = Format(Size / KB, "0.00") & "KB"
         Case Is < 100
            sRet = Format(Size / KB, "0.0") & "KB"
         Case Is < 1000
            sRet = Format(Size / KB, "0") & "KB"
         Case Is < 10000
            sRet = Format(Size / MB, "0.00") & "MB"
         Case Is < 100000
            sRet = Format(Size / MB, "0.0") & "MB"
         Case Is < 1000000
            sRet = Format(Size / MB, "0") & "MB"
         Case Is < 10000000
            sRet = Format(Size / MB / KB, "0.00") & "GB"
      End Select
      sRet = sRet & " (" & Format(Size, "#,##0") & " bytes)"
   End If
   FormatFileSize = sRet
End Function

' ********************************************
'  Private Methods
' ********************************************
Private Function FileTimeToDouble(ftUTC As FILETIME, Localize As Boolean) As Double
   Dim ft As FILETIME
   Dim st As SYSTEMTIME
   Dim d As Double
   Dim t As Double
   '
   ' Convert to local filetime, if necessary.
   '
   If Localize Then
      Call FileTimeToLocalFileTime(ftUTC, ft)
   Else
      ft = ftUTC
   End If
   '
   ' Convert to system time structure.
   '
   Call FileTimeToSystemTime(ft, st)
   '
   ' Convert to VB-style date (double).
   '
   FileTimeToDouble = DateSerial(st.wYear, st.wMonth, st.wDay) + _
                      TimeSerial(st.wHour, st.wMinute, st.wSecond)
End Function

Private Function ProperCasePath(ByVal PathIn As String) As String
   Dim hSearch As Long
   Dim wfd As WIN32_FIND_DATA
   Dim PathOut As String
   Dim i As Long
   '
   ' Trim trailing backslash, unless root dir.
   '
   If Right(PathIn, 1) = "\" Then
      If Right(PathIn, 2) <> ":\" Then
         PathIn = Left(PathIn, Len(PathIn) - 1)
      Else
         ProperCasePath = UCase(PathIn)
         Exit Function
      End If
   End If
   '
   ' Check for UNC share and return just that,
   ' if that's all that's left of PathIn.
   '
   If InStr(PathIn, "\\") = 1 Then
      i = InStr(3, PathIn, "\")
      If i > 0 Then
         If InStr(i + 1, PathIn, "\") = 0 Then
            ProperCasePath = PathIn
            Exit Function
         End If
      End If
   End If
   '
   ' Insure that path portion of string uses the
   ' same case as the real pathname.
   '
   If InStr(PathIn, "\") Then
      For i = Len(PathIn) To 1 Step -1
         If Mid(PathIn, i, 1) = "\" Then
            '
            ' Found end of previous directory.
            ' Recurse back up into path.
            '
            PathOut = ProperCasePath(Left(PathIn, i - 1)) & "\"
            '
            ' Use FFF to proper-case current directory.
            '
            hSearch = FindFirstFile(PathIn, wfd)
            If hSearch <> INVALID_HANDLE_VALUE Then
               Call FindClose(hSearch)
               If wfd.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY Then
                  ProperCasePath = PathOut & TrimNull(wfd.cFileName)
               End If
            End If
            '
            ' Bail out of loop.
            '
            Exit For
         End If
      Next i
   Else
      '
      ' Just a drive letter and colon,
      ' upper-case and return.
      '
      ProperCasePath = UCase(PathIn)
   End If
End Function

Private Function TrimNull(ByVal StrIn As String) As String
   Dim nul As Long
   '
   ' Truncate input string at first null.
   ' If no nulls, perform ordinary Trim.
   '
   nul = InStr(StrIn, vbNullChar)
   Select Case nul
      Case Is > 1
         TrimNull = Left(StrIn, nul - 1)
      Case 1
         TrimNull = ""
      Case 0
         TrimNull = Trim(StrIn)
   End Select
End Function


0
 
LVL 14

Expert Comment

by:waty
ID: 1445892
Here is a sample of use :

Create a form, add a picture called picIcon, run the function UpdateInfo with a file as parameter.

NB : The class ca retreive a lot of other informations.

Private Declare Function DrawIcon Lib "user32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal hIcon As Long) As Long

Private Sub UpdateInfo(ByVal file As String)
   Dim fi As CFileInfo

   Set fi = New CFileInfo
   fi.FullPathName = file

   '
   ' Display associated icon.
   '
   picIcon.Cls
   Call DrawIcon(picIcon.hdc, 0, 0, fi.hIcon)

End Sub
0
 

Author Comment

by:a_murray
ID: 1445893
The above code gives me a handle to the icon.  I cannot get the
icon onto a listview. waty can you help me with this?



0
Threat Intelligence Starter Resources

Integrating threat intelligence can be challenging, and not all companies are ready. These resources can help you build awareness and prepare for defense.

 
LVL 14

Expert Comment

by:waty
ID: 1445894
0
 

Author Comment

by:a_murray
ID: 1445895
waty, so far every solution works but requires the full path name, can you supply info to do the same, but with only a filename

Cheers

Andy
0
 
LVL 14

Expert Comment

by:waty
ID: 1445896
Private Declare Function FindExecutableA Lib "shell32.dll" (ByVal lpFile As String, ByVal lpdirectory As String, ByVal lpResult As String) As Long

Public Function FindExecutable(s As String) As String
   ' #VBIDEUtils#************************************************************
   ' * Programmer Name  : Waty Thierry
   ' * Web Site         : www.geocities.com/ResearchTriangle/6311/
   ' * E-Mail           : waty.thierry@usa.net
   ' * Date             : 7/12/98
   ' * Time             : 14:31
   ' * Module Name      : Shell_Module
   ' * Module Filename  : Execute.bas
   ' * Procedure Name   : FindExecutable
   ' * Parameters       :
   ' *                    s As String
   ' **********************************************************************
   ' * Comments         : Finds the executable associated with a file
   ' *
   ' *
   ' **********************************************************************

   Dim I    As Integer
   Dim s2   As String

   s2 = String(256, 32) & Chr$(0)

   I = FindExecutableA(s & Chr$(0), vbNullString, s2)

   If I > 32 Then
      FindExecutable = Left$(s2, InStr(s2, Chr$(0)) - 1)
   Else
      FindExecutable = ""
   End If

End Function
0

Featured Post

What Security Threats Are You Missing?

Enhance your security with threat intelligence from the web. Get trending threat insights on hackers, exploits, and suspicious IP addresses delivered to your inbox with our free Cyber Daily.

Join & Write a Comment

If you have ever used Microsoft Word then you know that it has a good spell checker and it may have occurred to you that the ability to check spelling might be a nice piece of functionality to add to certain applications of yours. Well the code that…
If you need to start windows update installation remotely or as a scheduled task you will find this very helpful.
As developers, we are not limited to the functions provided by the VBA language. In addition, we can call the functions that are part of the Windows operating system. These functions are part of the Windows API (Application Programming Interface). U…
Get people started with the utilization of class modules. Class modules can be a powerful tool in Microsoft Access. They allow you to create self-contained objects that encapsulate functionality. They can easily hide the complexity of a process from…

706 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

20 Experts available now in Live!

Get 1:1 Help Now