| The following code will open a file with its associated application. This code uses a function in the module at http://www.freevbcode.com/ShowCode.Asp?ID=314 in order to access the registry. This solution reads the registry to determine the default application for a given file extension. An alternative solution, using the ShellExecute API function, can be found at http://www.freevbcode.com/ShowCode.Asp?ID=12. Option Explicit Private Const REG_NONE As Long = 0 Private Const REG_SZ As Long = 1 Private Const REG_EXPAND_SZ As Long = 2 Private Const REG_BINARY As Long = 3 Private Const REG_DWORD As Long = 4 Private Const ERROR_SUCCESS As Long = 0 Private Const ERROR_ACCESS_DENIED As Long = 5 Private Const ERROR_NO_MORE_ITEMS As Long = 259 Private Const HKEY_CLASSES_ROOT As Long = &H80000000 Private Declare Function RegOpenKey Lib "advapi32.dll" _ Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As _ String, phkResult As Long) As Long Private Declare Function RegCloseKey Lib "advapi32.dll" _ (ByVal hKey As Long) As Long Private Declare Function RegQueryValueEx Lib "advapi32.dll" _ Alias "RegQueryValueExA" (ByVal hKey As Long, _ ByVal lpValueName As String, ByVal lpReserved As Long, _ lpType As Long, lpData As Any, lpcbData As Long) As Long Public Function OpenFile(ByVal pFileName As String) As Boolean ' Open the specified file with its associated application ' Return True if the file was open successfully ' False if its extension is not registered ' 'Example: OpenFile "C:\MyDocuments\MyDoc.doc" Dim lExtension As String Dim lType As String, lCommandLine As String Dim i As Integer OpenFile = False ' We identify the file extension lExtension = "." + GetFileExtension(pFileName) If Len(lExtension) > 1 Then ' If pFileName contains at least one space, it's a long filename, ' we add " characters If InStr(1, pFileName, " ") <> 0 Then pFileName = """" + pFileName + """" End If ' Get the corresponding file type in the registry lType = regQuery_A_Key(HKEY_CLASSES_ROOT, lExtension, "") If lType = "" Then ' Unknown type Exit Function End If ' Get the corresponding command line lCommandLine = regQuery_A_Key(HKEY_CLASSES_ROOT, _ lType + "\shell\open\command", "") If lCommandLine = "" Then ' No application can open this file type Exit Function End If ' Replace %1 with pFileName in lCommandLine If Not StringReplace(lCommandLine, "%1", _ pFileName) Then ' Add the file name at the end of the command line lCommandLine = lCommandLine + " " + pFileName End If ' Execute this command line Call Shell(lCommandLine, vbMaximizedFocus) OpenFile = True End If End Function Public Function StringReplace(pString1 As String, _ pString2 As String, pString3 As String) As Boolean 'Replace all the occurences of pString2 in pString1 by pString3 Dim i As Integer Dim lString As String StringReplace = False lString = pString1 i = InStr(1, lString, pString2) While i <> 0 StringReplace = True If i + Len(pString2) <= Len(lString) Then lString = Left(lString, i - 1) + pString3 + _ Right(lString, Len(lString) - i - Len(pString2) + 1) Else lString = Left(lString, i - 1) + pString3 End If i = InStr(1, lString, pString2) Wend pString1 = lString End Function Public Function regQuery_A_Key(ByVal hKey As Long, _ ByVal sRegKeyPath As String, _ ByVal sRegSubKey As String) As Variant ' -------------------------------------------------------------- ' Written by Kenneth Ives kenaso@home.com ' ' Important: If you treat all key data strings as being ' case sensitive, you should never have a problem. ' Always backup your registry files (System.dat ' and User.dat) before performing any type of ' modifications ' ' Description: Function for querying a sub key value. ' ' Parameters: ' hKey - HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, ' HKEY_lOCAL_MACHINE, HKEY_USERS, etc ' sRegKeyPath - is name of the key path you wish to traverse. ' sRegSubKey - is the name of the key which will be queryed. ' ' Syntax: ' sKeyQuery = regQuery_A_Key(HKEY_CURRENT_USER, _ ' "Software\AAA-Registry Test\Products", _ "StringTestData") ' ' Returns the key value of "StringTestData" ' -------------------------------------------------------------- ' -------------------------------------------------------------- ' Define variables ' -------------------------------------------------------------- Dim iPos As Integer Dim lKeyHandle As Long Dim lRet As Long Dim lDataType As Long Dim lBufferSize As Long Dim lBuffer As Long Dim sBuffer As String Dim arBuffer() As Byte ' -------------------------------------------------------------- ' Initialize variables ' -------------------------------------------------------------- lKeyHandle = 0 lBufferSize = 0 ' -------------------------------------------------------------- ' Query the key path ' -------------------------------------------------------------- lRet = RegOpenKey(hKey, sRegKeyPath, lKeyHandle) ' -------------------------------------------------------------- ' If no key handle was found then there is no key. Leave here. ' -------------------------------------------------------------- If lKeyHandle = 0 Then regQuery_A_Key = "" lRet = RegCloseKey(lKeyHandle) ' always close the handle Exit Function End If ' -------------------------------------------------------------- ' Query the registry and determine the data type. ' -------------------------------------------------------------- lRet = RegQueryValueEx(lKeyHandle, sRegSubKey, 0&, _ lDataType, ByVal 0&, lBufferSize) ' -------------------------------------------------------------- ' If no key handle was found then there is no key. Leave. ' -------------------------------------------------------------- If lKeyHandle = 0 Then regQuery_A_Key = "" lRet = RegCloseKey(lKeyHandle) ' always close the handle Exit Function End If ' -------------------------------------------------------------- ' Make the API call to query the registry based on the type ' of data. ' -------------------------------------------------------------- Select Case lDataType Case REG_SZ: ' String data (most common) ' Preload the receiving buffer area sBuffer = Space(lBufferSize) lRet = RegQueryValueEx(lKeyHandle, sRegSubKey, 0&, 0&, _ ByVal sBuffer, lBufferSize) ' If NOT a successful call then leave If lRet <> ERROR_SUCCESS Then regQuery_A_Key = "" Else ' Strip out the string data iPos = InStr(1, sBuffer, Chr(0)) ' look for the first null char If iPos > 0 Then ' if we found one, then save everything 'up to that point regQuery_A_Key = Left(sBuffer, iPos - 1) Else ' did not find one. Save everything. regQuery_A_Key = sBuffer End If End If Case REG_DWORD: ' Numeric data (Integer) lRet = RegQueryValueEx(lKeyHandle, sRegSubKey, _ 0&, lDataType, lBuffer, 4&) ' 4& = 4-byte word (long integer) ' If NOT a successful call then leave If lRet <> ERROR_SUCCESS Then regQuery_A_Key = "" Else ' Save the captured data regQuery_A_Key = lBuffer End If Case Else: ' unknown regQuery_A_Key = "" End Select ' -------------------------------------------------------------- ' Always close the handle in the registry. We do not want to ' corrupt these files. ' -------------------------------------------------------------- lRet = RegCloseKey(lKeyHandle) End Function Private Function GetFileExtension(pFileName As String) As String Dim i As Integer i = Len(pFileName) While Mid(pFileName, i, 1) <> "." i = i - 1 If i = 0 Then ' No extension Exit Function End If Wend GetFileExtension = Right(pFileName, Len(pFileName) - i) End Function |
Open a File with its Associated Application |
Express News India | Freelance ecommerce web development India