The new vbAccelerator Site - more VB and .NET Code and Controls
Source Code
3 Code Libraries Source Code &nbsp


NOTE: this code has been superceded by the version at the new site.



&nbsp

Icons for Any File Type

Icons For Any File Type Demonstration

Download the ShellIcon project files (17kb)

This project shows you how to get icons and file type names (for example, 'Visual Basic Project') for any file. You can get large and small icons with the code as shown. You can also get icons in the shell's current icon size, icons with a shortcut icon overlaid and selected icons by modifying the flag settings to the GetIcon function. The code also includes a simple Browse for Folder implementation.

This code is ideal for representing, for example, file attachments in your project. It probably isn't going to be any good for creating a replacement Windows Explorer - it can get into difficulties if you try and get too many icons, for example, trying to get all the icons in the Windows\System directory (mine has 1270 files so far and rising!). However, it works just great for smaller numbers of files.

Here is the code you need to get an icon and return a VB StdPicture object, which you can then assign to anything that takes a picture (for example, ImageLists, Form icons, PictureBoxes etc). If you want to use the icon directly with GDI methods you could instead return the hIcon. You can then use the DrawIcon or DrawImage to draw it into a DC. You must delete the icon afterwards using DeleteObject.

' =================================================================================
' Declares and types
' =================================================================================
Private Const MAX_PATH = 260
Private Type SHFILEINFO
&nbsp &nbsp hIcon As Long
&nbsp &nbsp iIcon As Long
&nbsp &nbsp dwAttributes As Long
&nbsp &nbsp szDisplayName As String * MAX_PATH
&nbsp &nbsp szTypeName As String * 80
End Type
Private Declare Function SHGetFileInfo Lib "shell32.dll" Alias "SHGetFileInfoA" _
&nbsp &nbsp (ByVal pszPath As String, ByVal dwAttributes As Long, psfi As SHFILEINFO, ByVal cbSizeFileInfo As Long, ByVal uFlags As Long) As Long
Private Enum EShellGetFileInfoConstants
&nbsp &nbsp &nbsp &nbsp SHGFI_ICON = &H100&nbsp &nbsp &nbsp &nbsp &nbsp &nbsp &nbsp &nbsp ' // get icon
&nbsp &nbsp &nbsp &nbsp SHGFI_DISPLAYNAME = &H200&nbsp &nbsp &nbsp &nbsp &nbsp &nbsp ' // get display name
&nbsp &nbsp &nbsp &nbsp SHGFI_TYPENAME = &H400&nbsp &nbsp &nbsp &nbsp &nbsp &nbsp ' // get type name
&nbsp &nbsp &nbsp &nbsp SHGFI_ATTRIBUTES = &H800&nbsp &nbsp &nbsp &nbsp &nbsp &nbsp ' // get attributes
&nbsp &nbsp &nbsp &nbsp SHGFI_ICONLOCATION = &H1000&nbsp &nbsp &nbsp &nbsp ' // get icon location
&nbsp &nbsp &nbsp &nbsp SHGFI_EXETYPE = &H2000&nbsp &nbsp &nbsp &nbsp &nbsp &nbsp ' // return exe type
&nbsp &nbsp &nbsp &nbsp SHGFI_SYSICONINDEX = &H4000&nbsp &nbsp &nbsp &nbsp ' // get system icon index
&nbsp &nbsp &nbsp &nbsp SHGFI_LINKOVERLAY = &H8000&nbsp &nbsp &nbsp &nbsp ' // put a link overlay on icon
&nbsp &nbsp &nbsp &nbsp SHGFI_SELECTED = &H10000&nbsp &nbsp &nbsp &nbsp &nbsp &nbsp ' // show icon in selected state
&nbsp &nbsp &nbsp &nbsp SHGFI_ATTR_SPECIFIED = &H20000&nbsp &nbsp ' // get only specified attributes
&nbsp &nbsp &nbsp &nbsp SHGFI_LARGEICON = &H0&nbsp &nbsp &nbsp &nbsp &nbsp &nbsp &nbsp &nbsp ' // get large icon
&nbsp &nbsp &nbsp &nbsp SHGFI_SMALLICON = &H1&nbsp &nbsp &nbsp &nbsp &nbsp &nbsp &nbsp &nbsp ' // get small icon
&nbsp &nbsp &nbsp &nbsp SHGFI_OPENICON = &H2&nbsp &nbsp &nbsp &nbsp &nbsp &nbsp &nbsp &nbsp ' // get open icon
&nbsp &nbsp &nbsp &nbsp SHGFI_SHELLICONSIZE = &H4&nbsp &nbsp &nbsp &nbsp &nbsp &nbsp ' // get shell size icon
&nbsp &nbsp &nbsp &nbsp SHGFI_PIDL = &H8&nbsp &nbsp &nbsp &nbsp &nbsp &nbsp &nbsp &nbsp &nbsp &nbsp ' // pszPath is a pidl
&nbsp &nbsp &nbsp &nbsp SHGFI_USEFILEATTRIBUTES = &H10&nbsp &nbsp ' // use passed dwFileAttribute
End Enum
Private Type PictDesc
&nbsp &nbsp cbSizeofStruct As Long
&nbsp &nbsp picType As Long
&nbsp &nbsp hImage As Long
&nbsp &nbsp xExt As Long
&nbsp &nbsp yExt As Long
End Type
Private Type Guid
&nbsp &nbsp Data1 As Long
&nbsp &nbsp Data2 As Integer
&nbsp &nbsp Data3 As Integer
&nbsp &nbsp Data4(0 To 7) As Byte
End Type
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (lpPictDesc As PictDesc, riid As Guid, ByVal fPictureOwnsHandle As Long, ipic As IPicture) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long

' =================================================================================
' Interface
' =================================================================================
Public Enum EGetIconTypeConstants
&nbsp &nbsp egitSmallIcon = 1
&nbsp &nbsp egitLargeIcon = 2
End Enum

Public Function GetIcon( _
&nbsp &nbsp &nbsp &nbsp ByVal sFIle As String, _
&nbsp &nbsp &nbsp &nbsp Optional ByVal EIconType As EGetIconTypeConstants = egitLargeIcon _
&nbsp &nbsp ) As Object
Dim lR As Long
Dim hIcon As Long
Dim tSHI As SHFILEINFO
Dim lFlags As Long
&nbsp &nbsp
&nbsp &nbsp ' Prepare flags for SHGetFileInfo to get the icon:
&nbsp &nbsp If (EIconType = egitLargeIcon) Then
&nbsp &nbsp &nbsp &nbsp lFlags = SHGFI_ICON Or SHGFI_LARGEICON
&nbsp &nbsp Else
&nbsp &nbsp &nbsp &nbsp lFlags = SHGFI_ICON Or SHGFI_SMALLICON
&nbsp &nbsp End If
&nbsp &nbsp lFlags = lFlags And Not SHGFI_LINKOVERLAY
&nbsp &nbsp lFlags = lFlags And Not SHGFI_OPENICON
&nbsp &nbsp lFlags = lFlags And Not SHGFI_SELECTED
&nbsp &nbsp ' Call to get icon:
&nbsp &nbsp lR = SHGetFileInfo(sFIle, 0&, tSHI, Len(tSHI), lFlags)
&nbsp &nbsp If (lR 0) Then
&nbsp &nbsp &nbsp &nbsp ' If we succeeded, the hIcon member will be filled in:
&nbsp &nbsp &nbsp &nbsp hIcon = tSHI.hIcon
&nbsp &nbsp &nbsp &nbsp ' If we have an icon, convert it to a VB picture and return it:
&nbsp &nbsp &nbsp &nbsp If (hIcon 0) Then
&nbsp &nbsp &nbsp &nbsp &nbsp &nbsp Set GetIcon = IconToPicture(hIcon)
&nbsp &nbsp &nbsp &nbsp End If
&nbsp &nbsp &nbsp &nbsp ' Free resouce:
&nbsp &nbsp &nbsp &nbsp DeleteObject hIcon
&nbsp &nbsp End If
&nbsp &nbsp
End Function
Public Function IconToPicture(ByVal hIcon As Long) As IPicture
&nbsp &nbsp
&nbsp &nbsp If hIcon = 0 Then Exit Function
&nbsp &nbsp &nbsp &nbsp
&nbsp &nbsp ' This is all magic if you ask me:
&nbsp &nbsp Dim NewPic As Picture, PicConv As PictDesc, IGuid As Guid
&nbsp &nbsp
&nbsp &nbsp PicConv.cbSizeofStruct = Len(PicConv)
&nbsp &nbsp PicConv.picType = vbPicTypeIcon
&nbsp &nbsp PicConv.hImage = hIcon
&nbsp &nbsp
&nbsp &nbsp 'IGuid.Data1 = &H20400
&nbsp &nbsp 'IGuid.Data4(0) = &HC0
&nbsp &nbsp 'IGuid.Data4(7) = &H46
&nbsp &nbsp ' Fill in magic IPicture GUID {7BF80980-BF32-101A-8BBB-00AA00300CAB}
&nbsp &nbsp With IGuid
&nbsp &nbsp &nbsp &nbsp .Data1 = &H7BF80980
&nbsp &nbsp &nbsp &nbsp .Data2 = &HBF32
&nbsp &nbsp &nbsp &nbsp .Data3 = &H101A
&nbsp &nbsp &nbsp &nbsp .Data4(0) = &H8B
&nbsp &nbsp &nbsp &nbsp .Data4(1) = &HBB
&nbsp &nbsp &nbsp &nbsp .Data4(2) = &H0
&nbsp &nbsp &nbsp &nbsp .Data4(3) = &HAA
&nbsp &nbsp &nbsp &nbsp .Data4(4) = &H0
&nbsp &nbsp &nbsp &nbsp .Data4(5) = &H30
&nbsp &nbsp &nbsp &nbsp .Data4(6) = &HC
&nbsp &nbsp &nbsp &nbsp .Data4(7) = &HAB
&nbsp &nbsp End With
&nbsp &nbsp OleCreatePictureIndirect PicConv, IGuid, True, NewPic
&nbsp &nbsp
&nbsp &nbsp Set IconToPicture = NewPic
&nbsp &nbsp
End Function
Public Function GetFileTypeName( _
&nbsp &nbsp &nbsp &nbsp ByVal sFIle As String _
&nbsp &nbsp ) As String
Dim lR As Long
Dim tSHI As SHFILEINFO
Dim iPos As Long

&nbsp &nbsp lR = SHGetFileInfo(sFIle, 0&, tSHI, Len(tSHI), SHGFI_TYPENAME)
&nbsp &nbsp If (lR 0) Then
&nbsp &nbsp &nbsp &nbsp iPos = InStr(tSHI.szTypeName, Chr$(0))
&nbsp &nbsp &nbsp &nbsp If (iPos = 0) Then
&nbsp &nbsp &nbsp &nbsp &nbsp &nbsp GetFileTypeName = tSHI.szTypeName
&nbsp &nbsp &nbsp &nbsp ElseIf (iPos > 1) Then
&nbsp &nbsp &nbsp &nbsp &nbsp &nbsp GetFileTypeName = Left$(tSHI.szTypeName, (iPos - 1))
&nbsp &nbsp &nbsp &nbsp Else
&nbsp &nbsp &nbsp &nbsp &nbsp &nbsp GetFileTypeName = ""
&nbsp &nbsp &nbsp &nbsp End If
&nbsp &nbsp End If
&nbsp &nbsp
End Function



Back to top

Back to Source Code Overview

&nbsp

AboutContributeSend FeedbackPrivacy

Copyright 1998-1999, Steve McMahon ( steve@vbaccelerator.com). All Rights Reserved.
Last updated: 15 August 1998