| ' * Programmer Name : Waty Thierry ' * Web Site : www.geocities.com/ResearchTriangle/6311/ ' * E-Mail : waty.thierry@usa.net ' * Date : 23/04/99 ' * Time : 14:40 ' * Comments : Get a list of registered file types ' * Returns: : Array of registered file extensions ' * with Description, separated by tab. ' * Sample Element: .vbp Visual Basic Project ' * Put declarations and function into a .bas module ' * Call the function by passing an empty string array. Then read back the answer from the same array: ' * e.g., dim sArray() as string, iCtr as integer ' * FileTypeNames sArray ' * For ictr = 0 to ubound(sArray) ' * Debug.print sArray(ictr) ' * Next '*************************************************************** Option Explicit Const MAX_PATH = 260 ' hKey values Private Const HKEY_CLASSES_ROOT = &H80000000 ' Return codes from Registration functions. Private Const ERROR_SUCCESS = 0 Private Const vbAscDot = 46 ' Asc(".") = 46 Private Type FILETIME ' ft dwLowDateTime As Long dwHighDateTime As Long 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 Type SHFILEINFO ' shfi hIcon As Long iIcon As Long dwAttributes As Long szDisplayName As String * MAX_PATH szTypeName As String * 80 End Type 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 SHGFI_flags) As Long Private Enum SHGFI_flags SHGFI_LARGEICON = &H0 ' sfi.hIcon is large icon SHGFI_SMALLICON = &H1 ' sfi.hIcon is small icon SHGFI_OPENICON = &H2 ' sfi.hIcon is open icon SHGFI_SHELLICONSIZE = &H4 ' sfi.hIcon is shell size (not 'system size), rtns BOOL SHGFI_PIDL = &H8 ' pszPath is pidl, rtns BOOL SHGFI_USEFILEATTRIBUTES = &H10 ' pretent pszPath exists, 'rtns BOOL SHGFI_ICON = &H100 ' fills sfi.hIcon, rtns BOOL, 'use DestroyIcon SHGFI_DISPLAYNAME = &H200 ' isf.szDisplayName is filled, 'rtns BOOL SHGFI_TYPENAME = &H400 ' isf.szTypeName is filled, rtns BOOL SHGFI_ATTRIBUTES = &H800 ' rtns 'IShellFolder::GetAttributesOf SFGAO_* flags SHGFI_ICONLOCATION = &H1000 ' fills sfi.szDisplayName 'with filename containing the 'icon, rtns BOOL SHGFI_EXETYPE = &H2000 ' rtns two ASCII chars of exe type SHGFI_SYSICONINDEX = &H4000 ' sfi.iIcon is sys il icon index, ' rtns hImagelist SHGFI_LINKOVERLAY = &H8000 ' add shortcut overlay to sfi.hIcon SHGFI_SELECTED = &H10000 ' sfi.hIcon is selected icon End Enum Public Sub FileTypeNames(FileTypeArray() As String) 'Populates FileTypeArray with registered extension 'and descriptions of them Dim lCtr As Long, lAns Dim sSubkey As String * MAX_PATH Dim sClass As String * MAX_PATH Dim ft As FILETIME Dim sTypeName As String ReDim FileTypeArray(0) As String lCtr = -1 lAns = -1 Do ' Walk thru each extension subkey. The sequence of keys ' enumed is completely random, (1st written to last 'written...?) lCtr = lCtr + 1 If RegEnumKeyEx(HKEY_CLASSES_ROOT, lCtr, sSubkey, _ MAX_PATH, 0, sClass, MAX_PATH, ft) = ERROR_SUCCESS Then If Asc(sSubkey) = vbAscDot Then ' Pass the entire string, GetFileTypeName uses 'everything before the 1st null char sTypeName = GetFileTypeName(sSubkey) If Len(sTypeName) Then lAns = lAns + 1 If lAns > 0 Then ReDim Preserve _ FileTypeArray(lAns) As String FileTypeArray(lAns) = GetStrFromBufferA(sSubkey) _ & vbTab & sTypeName End If End If Else Exit Do End If Loop End Sub Private Function GetFileTypeName(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 GetFileTypeName = GetStrFromBufferA(sfi.szTypeName) End If End Function Private Function GetStrFromBufferA(sz As String) As String 'ANSII String. If InStr(sz, vbNullChar) Then GetStrFromBufferA = Left$(sz, InStr(sz, vbNullChar) - 1) Else ' If sz had no null char, the Left$ function ' above would return a zero length string (""). GetStrFromBufferA = sz End If End Function |
Get a list of registered file types |
Express News India | Freelance ecommerce web development India