VB Snippet - List File Associations

[James Stanich]

Private Const MAX_PATH As Long = 260
Private Const HKEY_CLASSES_ROOT As Long = &H80000000
Private Const ERROR_SUCCESS As Long = 0
Private Const vbDot As Long = 46 
Private Const SHGFI_USEFILEATTRIBUTES As Long = &H10
Private Const SHGFI_TYPENAME As Long = &H400
Private Const LB_SETTABSTOPS As Long = &H192
 
Private Type FILETIME 
   dwLowDateTime As Long
   dwHighDateTime As Long
End Type
 
Private Type SHFILEINFO
   hIcon As Long
   iIcon As Long
   dwAttributes As Long
   szDisplayName As String * MAX_PATH
   szTypeName As String * 80
End Type
 
Private Declare Function RegEnumKeyEx Lib "advapi32.dll" Alias "RegEnumKeyExA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpName As String, lpcbName As Long, ByVal lpReserved As Long, ByVal lpClass As String, lpcbClass As Long, lpftLastWriteTime As FILETIME) As Long
Private Declare Function SHGetFileInfo Lib "shell32" Alias "SHGetFileInfoA" (ByVal pszPath As String, ByVal dwFileAttributes As Long, psfi As SHFILEINFO, ByVal cbFileInfo As Long, ByVal uFlags As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
 
Private Sub GetAssociatedFileListing()
 
   Dim dwIndex As Long
   Dim sTypeName As String
   Dim sSubkey As String * MAX_PATH
   Dim sClass As String * MAX_PATH
   Dim ft As FILETIME
   
   Do While RegEnumKeyEx(HKEY_CLASSES_ROOT, _
                         dwIndex, _
                         sSubkey, _
                         MAX_PATH, _
                         0, sClass, _
                         MAX_PATH, ft) = ERROR_SUCCESS
      
      If Asc(sSubkey) = vbDot Then
         
        'Pass the returned string to get the file type
         sTypeName = GetFileType(sSubkey)
            
         If Len(sTypeName) > 0 Then
            List1.AddItem TrimNull(sSubkey) & vbTab & sTypeName
         End If            
      End If
      dwIndex = dwIndex + 1   
   Loop
End Sub
 
Private Function GetFileType(sFile As String) As String
 
  'If successful returns the specified file's
  'typename, returns an empty string otherwise.
  'sFile does not have to exist and can be
  'just a file extension.
   Dim sfi As SHFILEINFO
 
   If SHGetFileInfo(sFile, 0&, _
                    sfi, Len(sfi), _
                    SHGFI_TYPENAME Or SHGFI_USEFILEATTRIBUTES) Then
      GetFileType = TrimNull(sfi.szTypeName)
   End If
 
End Function
 
Private Function TrimNull(startstr As String) As String
 
  'returns the string up to the first
  'null, if present, or the passed string
   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 Sub Command1_Click()
   List1.Clear
   Screen.MousePointer = vbHourglass   
  'fill the listbox box with the file types and their extensions
   Call GetAssociatedFileListing   
   Screen.MousePointer = vbDefault   
 
End Sub