Visual Basic Win32 Shell Routines
Undocumented Windows: Change Icon Dialog
The Change Icon Dialog
     
Posted:   Wednesday August 6, 1997
Updated:   Monday December 26, 2011
     
Applies to:   VB4-32, VB5, VB6
Developed with:   VB4-32, Windows 95
OS restrictions:   None
Author:   Brad Martinez
     

Related:  

SHChangeNotifyRegister: Receive Shell Change Notifications
Undocumented Windows: Overview
Undocumented Windows: Shell Dialogs
Undocumented Windows: Format Disk Dialog
Undocumented Windows: Path Functions
       
 Prerequisites
None.

Third in the undocumented Windows series demonstrates our SHChangeIconDialog API. Known in Shell32 as both _PickIcon and ordinal #62, it's another totally undocumented call with no mention of it or related functions on the MSDN CDs.

Still worth repeating: as an undocumented API, it is not supported in any way, shape or form by Microsoft. And once again, the demo contains routines designed to check for NT (thereby requiring different string handling), and to provide the demo interface with drive, file and directory lists.

The illustration below shows the demo form as it appears layout mode, where I've substituted control names for the control captions. Not indicated are five things: The Drive, File and Directory list boxes have the default control names (Drive1, File1 and Dir1). The two picture boxes are named picSmallIcon and picLargeIcon. If you can understand the code, you can figure which is which. The AutoRedraw and AutoSize properties of both are set to False. Finally, again the arrangement makes no difference, and the control and form names indicated match the code below.

 BAS Module Code
Once the form has been designed and saved, paste the following into the general declarations area of a file you name UndocSHChangeIcons.bas:

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.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  '------------------------------------------------------
  'Set to True if the current OS is WinNT.  
Public bIsWinNT As Boolean

Public Declare Function GetVersionEx Lib "kernel32" _
   Alias "GetVersionExA" _
  (lpVersionInformation As OSVERSIONINFO) As Long
                                     
Public Type OSVERSIONINFO
   dwOSVersionInfoSize As Long
   dwMajorVersion As Long
   dwMinorVersion As Long
   dwBuildNumber As Long
   dwPlatformId As Long
   szCSDVersion As String * 128
End Type
   
Public Const VER_PLATFORM_WIN32s = 0
Public Const VER_PLATFORM_WIN32_WINDOWS = 1
Public Const VER_PLATFORM_WIN32_NT = 2

Public Declare Function IsTextUnicode Lib "advapi32" _
   (lpBuffer As Any, _
    ByVal cb As Long, _
    lpi As Long) As Long
                               
Public Const IS_TEXT_UNICODE_ASCII16 = &H1
Public Const IS_TEXT_UNICODE_REVERSE_ASCII16 = &H10
Public Const IS_TEXT_UNICODE_STATISTICS = &H2
Public Const IS_TEXT_UNICODE_REVERSE_STATISTICS = &H20
Public Const IS_TEXT_UNICODE_CONTROLS = &H4
Public Const IS_TEXT_UNICODE_REVERSE_CONTROLS = &H40
Public Const IS_TEXT_UNICODE_SIGNATURE = &H8
Public Const IS_TEXT_UNICODE_REVERSE_SIGNATURE = &H80
Public Const IS_TEXT_UNICODE_ILLEGAL_CHARS = &H100
Public Const IS_TEXT_UNICODE_ODD_LENGTH = &H200
Public Const IS_TEXT_UNICODE_DBCS_LEADBYTE = &H400
Public Const IS_TEXT_UNICODE_NULL_BYTES = &H1000
Public Const IS_TEXT_UNICODE_UNICODE_MASK = &HF
Public Const IS_TEXT_UNICODE_REVERSE_MASK = &HF0
Public Const IS_TEXT_UNICODE_NOT_UNICODE_MASK = &HF00
Public Const IS_TEXT_UNICODE_NOT_ASCII_MASK = &HF000
  
  '------------------------------------------------------
  'The "Change Icon" dialog.
  '------------------------------------------------------
Public Declare Function SHChangeIconDialog Lib "shell32" _
   Alias "#62" _
  (ByVal hOwner As Long, _
   ByVal szFilename As String, _
   ByVal Reserved As Long, _
   lpIconIndex As Long) As Long
  
'hOwner = Dialog owner, specify 0 for desktop 
'(will be top-level)
'szFilename = The initially displayed filename, filled 
'             on selection. Should be allocated to 
'             MAX_PATH (260) in order to receive the 
'             selected filename's path.
'Reserved = ?
'lpIconIndex = Pointer to the initially displayed filename's 
'              icon index, and is filled on icon selection.
 
'Returns non-zero on select, zero if cancelled.
   
'------------------------------------------------------
'A utilized undocumented Path function :
'------------------------------------------------------
'Inserts a backslash before the first null char in szPath.
'szPath is unchanged if it already contains a backslash
'before the first null char or contains no null char at all.
'Rtn pointer to?
'Does not check szPath for validity.
'(the name almost fits...)   
Public Declare Function SHAddBackslash Lib "shell32" _
   Alias "#32" _
  (ByVal szPath As String) As Long
  
'-------------------------------
'A few slightly more familiar APIs required...
'-------------------------------
'Maximum long filename path-length
Public Const MAX_PATH As Long = 260

Public Declare Function GetWindowsDirectory Lib "kernel32" _
        Alias "GetWindowsDirectoryA" _
        (ByVal lpBuffer As String, _
         ByVal nSize As Long) As Long
   
Public Declare Function ExtractIconEx Lib "shell32" _
        Alias "ExtractIconExA" _
        (ByVal lpszFile As String, _
         ByVal nIconIndex As Long, _
         phiconLarge As Long, _
         phiconSmall As Long, _
         ByVal nIcons As Long) As Long
         
Public Declare Function DrawIconEx Lib "user32" _
        (ByVal hDC As Long, _
         ByVal xLeft As Long, _
         ByVal yTop As Long, _
         ByVal hIcon As Long, _
         ByVal cxWidth As Long, _
         ByVal cyWidth As Long, _
         ByVal istepIfAniCur As Long, _
         ByVal hbrFlickerFreeDraw As Long, _
         ByVal diFlags As Long) As Boolean
   
Public Declare Function DestroyIcon Lib "user32" _
        (ByVal hIcon As Long) As Long
  
'Required DrawIconEx() diFlags values:  
Public Const DI_MASK = &H1
Public Const DI_IMAGE = &H2
Public Const DI_NORMAL = &H3
Public Const DI_COMPAT = &H4
Public Const DI_DEFAULTSIZE = &H8
  
'Handles overlapped source and destination blocks  
Public Declare Sub CopyMemory Lib "kernel32" _
   Alias "RtlMoveMemory" _
  (pDest As Any, _
   pSource As Any, _
   ByVal ByteLen As Long)
 

Public Function MakeMaxPath(ByVal sPath As String) As String
  
  'Terminates sPath w/ null chars making
  'the return string MAX_PATH chars long.  
   MakeMaxPath = sPath & String$(MAX_PATH - Len(sPath), 0)
  
End Function


Public Function IsUnicodeStr(sBuffer As String) As Boolean
  
  'Returns True if sBuffer evaluates to a Unicode string  
   Dim dwRtnFlags As Long
   
   dwRtnFlags = IS_TEXT_UNICODE_UNICODE_MASK
   IsUnicodeStr = IsTextUnicode(ByVal sBuffer, Len(sBuffer), dwRtnFlags)

End Function


Public Function GetStrFromBuffer(szStr As String) As String
   
  'Returns string before first null char encountered (if any)
  'from either an ANSII or Unicode string buffer.  
   If IsUnicodeStr(szStr) Then szStr = StrConv(szStr, vbFromUnicode)
   
   If InStr(szStr, vbNullChar) Then
      GetStrFromBuffer = Left$(szStr, InStr(szStr, vbNullChar) - 1)
   Else
      GetStrFromBuffer = szStr
   End If

End Function


Public Function CheckString(msg As String) As String

   If bIsWinNT Then
      CheckString = StrConv(msg, vbUnicode)
   Else
      CheckString = msg
   End If
   
End Function


Public Function IsWinNT() As Boolean
  
  'Returns True if the current operating system is WinNT  
   Dim osvi As OSVERSIONINFO
   osvi.dwOSVersionInfoSize = Len(osvi)
   GetVersionEx osvi
   IsWinNT = (osvi.dwPlatformId = VER_PLATFORM_WIN32_NT)
   
End Function


Public Function NormalizePath(sPath As String) As String
  
  'check the string type (ANSI or Unicode),
  'converting as required. 
   
  'Check with If .. Then for a slash; if it's
  'needed, add a trailing null string after the
  'Checked string, as SHAddBackslash inserts a
  'backslash before the first null char in szPath. 
   sPath = CheckString(sPath)
   
   If Right$(sPath, 1) <> "\" Then
     
  'do what is says 
   sPath = sPath & vbNullChar
      SHAddBackslash sPath
      
   End If
   
  'and return the string  
   NormalizePath = sPath
  
End Function
 Form Code
To the project form illustrated above add the following code:

Option Explicit

Private Sub cmdEnd_Click()

   Unload Me
   
End Sub


Private Sub Dir1_Change()
    
    Dir1.Path = Drive1.Drive
    File1 = Dir1.Path
    txtIconPath = Dir1.Path

End Sub


Private Sub Drive1_Change()

    Dir1.Path = Drive1.Drive
  
End Sub


Private Sub File1_Click()

   txtIconPath = NormalizePath(File1.Path) & LCase$(File1)

End Sub


Private Sub File1_DblClick()

   DoIconDialog
   
End Sub


Private Sub Form_Load()

   Dim r As Long
   Dim sDirBuff As String
  
  'We'll need this flag to determine if
  'strings should be converted to Unicode  
   bIsWinNT = IsWinNT
   
   Move (Screen.Width - Width) * 0.5, (Screen.Height - Height) * 0.5
   
  'Setup the rest of the controls
   txtIconIdx = 0
   
   sDirBuff = Space$(MAX_PATH)
   r = GetWindowsDirectory(sDirBuff, MAX_PATH)
   
   If r Then
      Drive1.Drive = LCase$(Left$(sDirBuff, 3))     'ie "c:\"
      Dir1.Path = LCase$(GetStrFromBuffer(sDirBuff))'ie "c:\windows"
   End If
    
End Sub


Private Sub cmdIconDlg_Click()

   DoIconDialog
  
End Sub


Private Sub DoIconDialog()
  
   Dim sFileName As String
   Dim nIconIdx As Long        '0 on init
   Dim hSmallIcon As Long
   Dim hLargeIcon As Long
   
  'Allocate rtn buffer  
   sFileName = MakeMaxPath(txtIconPath)
   
  'convert it to Unicode if required  
   sFileName = CheckString(sFileName)
   
  'assign the icon number in txtIconIndex
  'to a Long. If it's empty, assign 0 to
  'prevent an error.  
   If Val(txtIconIdx) Then
      nIconIdx = Val(txtIconIdx)
   Else
      nIconIdx = 0
   End If
   
  'Returns 1 if selection, 0 if cancelled  
   If SHChangeIconDialog(Me.hWnd, sFileName, 0, nIconIdx) Then
  
  'Display selection  
   txtIconPath = GetStrFromBuffer(sFileName)
   txtIconIdx = nIconIdx
     
     'Returns number of icons extracted, 0 on 
     'error, -1 if invalid filename.
     'Creates specified number of icons and must 
     'all be destroyed when no longer need (frees 
     'the memory they occupy).  
      If ExtractIconEx(sFileName, nIconIdx, hLargeIcon, hSmallIcon, 1) > 0 Then
      
         picSmallIcon.AutoRedraw = True
         picLargeIcon.AutoRedraw = True
         
         picSmallIcon.Cls
         picLargeIcon.Cls
        
        'See MSKB article ID Q141933 for info on 
        'creating a picture object from an image handle 
        '(which can then be assigned to a picture box
        'picture property)  
         DrawIconEx picSmallIcon.hDC, 1, 1, hSmallIcon, 0, 0, 0, 0, DI_NORMAL
         DrawIconEx picLargeIcon.hDC, 1, 1, hLargeIcon, 0, 0, 0, 0, DI_NORMAL
         
         DestroyIcon hSmallIcon
         DestroyIcon hLargeIcon
         
         picSmallIcon.AutoRedraw = False
         picLargeIcon.AutoRedraw = False
         
      End If
  End If

End Sub
 Comments
Save the project before running.

When a file containing icons is selected, the Change Icon dialog will display. If the file has no icons, the message "The file (filename) contains no icons. Choose an icon from the list or specify a different file". The default Shell32.dll icon library is presented for selection instead.

Once the icons are in the picture boxes and the DoIconDialog() routine has completed, they can be saved to disk with the SavePicture method.


 
 

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