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" _
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 Form_Load()
ReDim TabArray(0) As Long
TabArray(0) = 75
Call SendMessage(List1.hwnd, LB_SETTABSTOPS, 0&, ByVal 0&)
Call SendMessage(List1.hwnd, LB_SETTABSTOPS, 1&, TabArray(0))
List1.Refresh
Command1.Caption = "Get Associations"
End Sub
Private Sub Command1_Click()
List1.Clear
Me.MousePointer = 11
Call GetAssociatedFileListing
Me.MousePointer = 0
End Sub
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
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
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
Public Function TrimNull(startstr As String) As 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 Functio