'------------------------------------------------------
  '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

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