Visual Basic Icon Routines
ExtractIcon: Viewing Application Icons in a Scrollable Viewport
Posted:   Monday May 1, 2000
Updated:   Monday December 26, 2011
Applies to:   VB4-32, VB5, VB6
Developed with:   VB6, Windows NT4
OS restrictions:   None
Author:   VBnet - Randy Birch


SendMessage: Move Controls to Simulate Form Scrolling
ExtractIcon: Retrieving and Viewing Application Icons

This ExtractIcon demo is a wee bit more involved than the basic demo listed above. Here, the FindFirstFile search APIs are used to retrieve all the specified file types in a given path, optionally recursing the specified path. As each filename is retrieved, the number of icons in that file are retrieved using ExtractIcon, along with the file type as stored in the registry, using GetFileVersionInfoSize and VerQueryValue, and the results populate a ListView control.

On clicking a listed entry, the scrollable picture box viewport beneath the ListView is populated with all the icons in the selected file, numbered accordingly (0-based).

Once again, writing any of these icons to disk is an exercise left to the programmer.

Note that in the layout diagram (which you can click to open in its own page), Picture1 is contained inside Picture2, not on top of it. This is essential to allow Picture1 to provide a scrollable viewport.

 BAS Module Code
Place the following code into the general declarations area of a bas module:

Option Explicit
' Copyright 1996-2011 VBnet/Randy Birch, All Rights Reserved.
' Some pages may also contain other copyrights by the author.
' Distribution: You can freely use this code in your own
'               applications, but you may not reproduce 
'               or publish this code on any web site,
'               online service, or distribute as source 
'               on any media without express permission.
Public Const MAXDWORD As Long = &HFFFFFFFF
Public Const MAX_PATH As Long = 260

Public Type FILETIME
   dwLowDateTime As Long
   dwHighDateTime As Long
End Type

Public 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

   bRecurse As Boolean
   bList As Boolean
   bFound As Boolean     'not used in this demo
   sFileRoot As String
   sFileNameExt As String
   sResult As String     'not used in this demo
   nFileCount As Long    'not used in this demo
   nFileSize As Double   'not used in this demo
End Type

Public Declare Function FindClose Lib "kernel32" _
  (ByVal hFindFile As Long) As Long
Public Declare Function FindFirstFile Lib "kernel32" _
   Alias "FindFirstFileA" _
  (ByVal lpFileName As String, _
   lpFindFileData As WIN32_FIND_DATA) As Long
Public Declare Function FindNextFile Lib "kernel32" _
   Alias "FindNextFileA" _
  (ByVal hFindFile As Long, _
   lpFindFileData As WIN32_FIND_DATA) As Long
Public Declare Function lstrcpyA Lib "kernel32" _
  (ByVal RetVal As String, ByVal Ptr As Long) As Long
Public Declare Function lstrlenA Lib "kernel32" _
  (ByVal Ptr As Any) As Long

   dwSignature As Long
   dwStrucVersion As Long      'e.g. 0x00000042 = "0.42"
   dwFileVersionMS As Long     'e.g. 0x00030075 = "3.75"
   dwFileVersionLS As Long     'e.g. 0x00000031 = "0.31"
   dwProductVersionMS As Long  'e.g. 0x00030010 = "3.10"
   dwProductVersionLS As Long  'e.g. 0x00000031 = "0.31"
   dwFileFlagsMask As Long     '= 0x3F for version "0.42"
   dwFileFlags As Long         'e.g. VFF_DEBUG Or VFF_PRERELEASE
   dwFileOS As Long            'e.g. VOS_DOS_WINDOWS16
   dwFileType As Long          'e.g. VFT_DRIVER
   dwFileSubtype As Long       'e.g. VFT2_DRV_KEYBOARD
   dwFileDateMS As Long        'e.g. 0
   dwFileDateLS As Long        'e.g. 0
End Type

Public Declare Function GetFileVersionInfoSize Lib "version.dll" _
   Alias "GetFileVersionInfoSizeA" _
  (ByVal lptstrFilename As String, _
   lpdwHandle As Long) As Long

Public Declare Function GetFileVersionInfo Lib "version.dll" _
   Alias "GetFileVersionInfoA" _
  (ByVal lptstrFilename As String, _
   ByVal dwHandle As Long, _
   ByVal dwLen As Long, _
   lpData As Any) As Long
Public Declare Function VerQueryValue Lib "version.dll" _
   Alias "VerQueryValueA" _
  (pBlock As Any, _
   ByVal lpSubBlock As String, _
   lplpBuffer As Any, nVerSize As Long) As Long

Public Declare Sub CopyMemory Lib "kernel32" _
   Alias "RtlMoveMemory" _
  (Destination As Any, _
   Source As Any, _
   ByVal Length As Long)

Private Function GetPointerToString(lpString As Long, nBytes As Long) As String

   Dim Buffer As String
   If nBytes Then
      Buffer = Space$(nBytes)
      CopyMemory ByVal Buffer, ByVal lpString, nBytes
      GetPointerToString = Buffer
   End If
End Function

Private Function GetStrFromPtrA(ByVal lpszA As Long) As String

   GetStrFromPtrA = String$(lstrlenA(ByVal lpszA), 0)
   Call lstrcpyA(ByVal GetStrFromPtrA, ByVal lpszA)
End Function

Public Function GetFileDescription(sSourceFile As String) As String

   Dim sBuffer() As Byte
   Dim nBufferSize As Long
   Dim lpBuffer As Long
   Dim nVerSize As Long
   Dim nUnused As Long
   Dim tmpVer As String
   Dim sBlock As String
   If Len(sSourceFile) > 0 Then

     'set file that has the encryption level
     'info and call to get required size
      nBufferSize = GetFileVersionInfoSize(sSourceFile, nUnused)
      ReDim sBuffer(nBufferSize)
      If nBufferSize > 0 Then
        'get the version info
         Call GetFileVersionInfo(sSourceFile, 0&, nBufferSize, sBuffer(0))
         Call VerQueryValue(sBuffer(0), "\", lpBuffer, nVerSize)
         Call CopyMemory(FI, ByVal lpBuffer, Len(FI))
         If VerQueryValue(sBuffer(0), "\VarFileInfo\Translation", lpBuffer, nVerSize) Then
            If nVerSize Then
               tmpVer = GetPointerToString(lpBuffer, nVerSize)
               tmpVer = Right("0" & Hex(Asc(Mid(tmpVer, 2, 1))), 2) & _
                        Right("0" & Hex(Asc(Mid(tmpVer, 1, 1))), 2) & _
                        Right("0" & Hex(Asc(Mid(tmpVer, 4, 1))), 2) & _
                        Right("0" & Hex(Asc(Mid(tmpVer, 3, 1))), 2)
               sBlock = "\StringFileInfo\" & tmpVer & "\FileDescription"
              'Get predefined version resources
               If VerQueryValue(sBuffer(0), sBlock, lpBuffer, nVerSize) Then
                  If nVerSize Then
                    'get the file description
                     GetFileDescription = GetStrFromPtrA(lpBuffer)

                  End If  'If nVerSize
               End If  'If VerQueryValue
            End If  'If nVerSize
         End If  'If VerQueryValue
      End If  'If nBufferSize
   End If  'If sSysPath

End Function
 Form Code
Design a form similar to that in the illustration above (click the picture to open page with just the layout form), consisting of a ListView, VScrollBar, Command Button, Checkbox, Text box, and Combo. All controls can retain their default control names. Add two Picture boxes (with AutoRedraw=True for Picture 1, and both set to ScaleMode=twips), and set Picture1's properties to remove the border and 3D effect. Ensure Picture1 is contained within Picture2 (an not just overtop) to achieve the scrolling viewport effect.

Add the following code to the form:

Option Explicit
Private Const vbDot As Long= 46
Private twipsX As Long
Private twipsY As Long

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 Declare Function ExtractIcon Lib "shell32" _
   Alias "ExtractIconA" _
  (ByVal hInst As Long, _
   ByVal lpszExeFileName As String, _
   ByVal nIconIndex As Long) As Long
Private Declare Function DestroyIcon Lib "user32" _
  (ByVal hIcon As Long) As Long

Private Sub Form_Load()

   With Combo1
      .AddItem "*.*"
      .AddItem "*.exe"
      .AddItem "*.dll"
      .AddItem "*.ocx"
      .AddItem "*.ico"
      .ListIndex = 1
   End With
   twipsX = Screen.TwipsPerPixelX
   twipsY = Screen.TwipsPerPixelY
   With ListView1
      .ColumnHeaders.Add , , "File"
      .ColumnHeaders.Add , , "Icons"
      .ColumnHeaders.Add , , "File Type"
      .ColumnHeaders.Add , , "Full Filename"
      .View = lvwReport
      .FullRowSelect = True  'VB6 only
      .HideSelection = False 'VB6 only
   End With
   Text1.Text = LCase$(Environ$("WINDIR") & "\system32")   
End Sub

Private Sub Command1_Click()

   With FP
      .sFileRoot = Text1.Text
      .sFileNameExt = Combo1.Text
      .bRecurse = Check1.Value = 1
      .bList = True
   End With
   Screen.MousePointer = vbHourglass
   Call SearchForFiles(FP)
   Screen.MousePointer = vbDefault
End Sub

Private Sub GetFileInformation(FP As FILE_PARAMS)

   Dim hFile As Long
   Dim sPath As String
   Dim sRoot As String
   Dim sTmp As String
   Dim itmx As ListItem
   Dim nIconCount As Long
   Dim lv As Control
   Set lv = ListView1
  'FP.sFileRoot (assigned to sRoot) contains
  'the path to search.
  'FP.sFileNameExt (assigned to sPath) contains
  'the full path and filespec.
   sRoot = QualifyPath(FP.sFileRoot)
   sPath = sRoot & FP.sFileNameExt
  'obtain handle to the first filespec match
   hFile = FindFirstFile(sPath, WFD)
  'if valid ...

        'remove trailing nulls
         sTmp = TrimNull(WFD.cFileName)
        'Even though this routine uses filespecs,
        '*.* is still valid and will cause the search
        'to return folders as well as files, so a
        'check against folders is still required.
         If Not (WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) _

            nIconCount = GetFileIconCount(sRoot & sTmp)

           'add to the list if the flag indicates
            If FP.bList And nIconCount > 0 Then
              'got the data, so add it to the listview
               Set itmx = lv.ListItems.Add(, , LCase$(sTmp))
               itmx.SubItems(1) = nIconCount
               itmx.SubItems(2) = GetFileDescription(sRoot & sTmp)
               itmx.SubItems(3) = LCase$(sRoot & sTmp)
            End If
         End If
      Loop While FindNextFile(hFile, WFD)
     'close the handle
      hFile = FindClose(hFile)
   End If

End Sub

Public Function TrimNull(startstr As String) As String

  'returns the string up to the first
  'null, if present, or the passed str
   Dim pos As Integer
   pos = InStr(startstr, Chr$(0))
   If pos Then
      TrimNull = Left$(startstr, pos - 1)
      Exit Function
   End If
   TrimNull = startstr
End Function

Private Function QualifyPath(sPath As String) As String

  'assures that a passed path ends in a slash
   If Right$(sPath, 1) <> "\" Then
      QualifyPath = sPath & "\"
      QualifyPath = sPath
   End If
End Function

Private Sub SearchForFiles(FP As FILE_PARAMS)

   Dim hFile As Long
   Dim sPath As String
   Dim sRoot As String
   Dim sTmp As String
   sRoot = QualifyPath(FP.sFileRoot)
   sPath = sRoot & "*.*"
  'obtain handle to the first match
   hFile = FindFirstFile(sPath, WFD)
  'if valid ...
     'This is where the method obtains the file
     'list and data for the folder passed.

      Call GetFileInformation(FP)

        'if the returned item is a folder...
         If (WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) Then
           '..and the Recurse flag was specified
            If FP.bRecurse Then
              'remove trailing nulls
               sTmp = TrimNull(WFD.cFileName)
              'and if the folder is not the default
              'self and parent folders...
               If Asc(sTmp) <> vbDot Then
                 'append new path and search that folder
                  FP.sFileRoot = sRoot & sTmp
                  Call SearchForFiles(FP)
               End If
            End If
         End If
     'continue looping until FindNextFile returns
     '0 (no more matches)
      Loop While FindNextFile(hFile, WFD)
     'close the find handle
      hFile = FindClose(hFile)
   End If
End Sub

Private Sub GetFileIcons(sIconFile As String)

   Dim thisRow As Long
   Dim thisCol As Long
   Dim numIcons As Long
   Dim numRowsNeeded As Long
   Dim rowX As Long
   Dim colX As Long
   Dim cnt As Long
   Dim hIcon As Long
  'This needs to be set  - as coded it will display
  '10 items across, regardless whether the viewport
  'will show all 10. In a practical application
  'this value would be calculated based on the 
  'the width of the viewport window, divided by
  'the width of the icon plus any additional padding
  'added to spread them apart on screen.
  'If you see strange results (ie only 2 partial 
  'rows icons when the file contains 20, for example, 
  'tweak this number down to correctly reflect the 
  'number that can comfortably fit the viewport
  'without a horizontal scrollbar. 
   Const maxPerRow As Long = 10
  'how many icons in the file?
   numIcons = GetFileIconCount(sIconFile)
  'if one or more ...
   If numIcons > 0 Then
     'calc the number of rows needed. Note
     'that this is hard-coded for 10 per line.
     'A more precise way of doing this would be
     'to calc the size of the pixbox, the size
     'of an icon, and the inter-icon spacing desired,
     'to dynamically calc the number of icons per row.
      numRowsNeeded = numIcons \ maxPerRow
     'avoid error
      If numRowsNeeded = 0 Then numRowsNeeded = 1
     'this adds an extra row if numIcons \ 10
     'results in a remainder
      If numRowsNeeded Mod numIcons Then
         numRowsNeeded = numRowsNeeded + 1
      End If
     'establish initial positions and size.
      With Picture1
         .Left = 0
         .Top = 0
         .Height = (numRowsNeeded * 66) * twipsX
         .Width = Picture2.Width * twipsY
         For thisRow = 0 To numRowsNeeded - 1
            For thisCol = 0 To maxPerRow - 1
              'this calcs the position within
              'the pixbox to draw the icon
               rowX = (thisCol * 48)
               colX = (thisRow * 60) + 8
               If thisCol = 0 Then rowX = rowX + 8
                 'get the icon in position
                 'specified by cnt
                  hIcon = ExtractIcon(0&, sIconFile, cnt)
                  If hIcon Then
                    'draw the icon
                     Call DrawIcon(Picture1.hdc, rowX, colX, hIcon)

                    'add a number underneath indicating
                    'the icon number in the file
                     .ForeColor = vbBlue
                     .CurrentX = rowX + 2
                     .CurrentY = colX + 33
                    'can't use a With statement against
                    'a Print method!
                     Picture1.Print cnt
                    'we don't need that icon any
                    'longer, so toast it
                     Call DestroyIcon(hIcon)
                  End If  'If hIcon
               cnt = cnt + 1
            Next  'For thisCol
         Next  'For thisRow
      End With  'With Picture1
   End If  'If numIcons
  'now that the pixbox contains the icons,
  'set the scrollbar properties to the
  'correct values
   VScroll1.Min = 0
   VScroll1.Value = 0
   VScroll1.Enabled = True
   If numRowsNeeded > 5 Then
      VScroll1.Max = numRowsNeeded + (75)
      VScroll1.Enabled = True
      VScroll1.Max = numRowsNeeded
      VScroll1.Enabled = False
   End If

End Sub

Private Function GetFileIconCount(sIconFile As String) As Long

   GetFileIconCount = ExtractIcon(0&, sIconFile, -1)

End Function

Private Sub ListView1_ColumnClick(ByVal ColumnHeader As MSComctlLib.ColumnHeader)

   ListView1.SortKey = ColumnHeader.index - 1
   ListView1.SortOrder = Abs(Not ListView1.SortOrder = 1)
   ListView1.Sorted = True
End Sub

Private Sub ListView1_ItemClick(ByVal Item As MSComctlLib.ListItem)

   Call GetFileIcons(Item.SubItems(3))

End Sub

Private Sub VScroll1_Change()

   Picture1.Top = (VScroll1.Value / 100) * (Picture2.ScaleHeight - Picture1.Height)

End Sub

Private Sub VScroll1_Scroll()

   Picture1.Top = (VScroll1.Value / 100) * (Picture2.ScaleHeight - Picture1.Height)

End Sub
Change the path constant to point to your system or system32 folder, and run. Press the command button, and navigate through the icons in shell32.dll using the up/down control, or the two alternate command buttons added.


PayPal Link
Make payments with PayPal - it's fast, free and secure!


Copyright 1996-2011 VBnet and Randy Birch. All Rights Reserved.
Terms of Use  |  Your Privacy


Hit Counter