Open a File with its Associated Application

Category:

Files and Directories

Type:

Snippets

Difficulty:

Intermediate

Author: Guillaume Serre

Version Compatibility: Visual Basic 5

More information:

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.

Instructions: Copy the declarations and code below and paste directly into your VB project.

Declarations:
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

Code:

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