Seznam registrovaných přípon souborů

Public Const MAX_PATH = 260
Public Const HKEY_CLASSES_ROOT = &H80000000
Public Const ERROR_SUCCESS = 0
Public Const vbAscDot = 46 ' Asc(".") = 46
Type FILETIME ' ft
   dwLowDateTime As Long
   dwHighDateTime As Long
End Type

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

Public Type SHFILEINFO 
   hIcon As Long
   iIcon As Long
   dwAttributes As Long
   szDisplayName As String * MAX_PATH
   szTypeName As String * 80
End Type

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 SHGFI_flags) As Long

Enum SHGFI_flags
   SHGFI_LARGEICON = &H0
   SHGFI_SMALLICON = &H1
   SHGFI_OPENICON = &H2 
   SHGFI_SHELLICONSIZE = &H4 
   SHGFI_PIDL = &H8
   SHGFI_USEFILEATTRIBUTES = &H10 
   SHGFI_ICON = &H100
   SHGFI_DISPLAYNAME = &H200
   SHGFI_TYPENAME = &H400
   SHGFI_ATTRIBUTES = &H800 
   SHGFI_ICONLOCATION = &H1000 
   SHGFI_EXETYPE = &H2000 
   SHGFI_SYSICONINDEX = &H4000 
   SHGFI_LINKOVERLAY = &H8000 
   SHGFI_SELECTED = &H10000 
End Enum

Public Function GetFileTypeName(sFile As String) As String

   Dim sfi As SHFILEINFO

   If SHGetFileInfo(sFile, 0, sfi, Len(sfi), _
     SHGFI_TYPENAME Or SHGFI_USEFILEATTRIBUTES) Then
      GetFileTypeName = GetStrFromBufferA(sfi.szTypeName)
   End If

End Function

Public Function GetStrFromBufferA(sz As String) As String

   If InStr(sz, vbNullChar) Then
      GetStrFromBufferA = Left$(sz, InStr(sz, vbNullChar) - 1)
   Else
      GetStrFromBufferA = sz
   End If

End Function

Na formulář přidejte ListBox a tlačítko. V deklarační části formuláře:

Private Sub InsertFileTypeNames()

   Dim i As Long
   Dim sSubkey As String * MAX_PATH
   Dim sClass As String * MAX_PATH
   Dim ft As FILETIME
   Dim sTypeName As String

   i = -1
   Do
      i = i + 1
      If RegEnumKeyEx(HKEY_CLASSES_ROOT, i, sSubkey, MAX_PATH, _
            0, sClass, MAX_PATH, ft) = ERROR_SUCCESS Then
         If Asc(sSubkey) = vbAscDot Then
            sTypeName = GetFileTypeName(sSubkey)
            If Len(sTypeName) Then
               List1.AddItem GetStrFromBufferA(sSubkey) & vbTab & sTypeName
            End If
         End If
      Else
         Exit Do
      End If
   Loop

End Sub

Private Sub Command1_Click()
   
   List1.Clear
   MousePointer = 11
   Call InsertFileTypeNames
   MousePointer = 0

End Sub

Zpět