Private Declare Function RegOpenKeyEx Lib "advapi32.dll" _
    Alias "RegOpenKeyExA" ( _
    ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, _
    ByVal samDesired As Long, phkResult 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, _
    ByVal lpData As String, ByRef lpcbData As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" ( _
    ByVal hKey As Long) As Long

Private Const HKEY_LOCAL_MACHINE = &H80000002
Private Const ERROR_SUCCESS = 0&
Private Const KEY_QUERY_VALUE = &H1
Private Const REG_SZ = 1

Public Function GetExcelPath(ByVal Version As Long) As String
    Dim hKey As Long, lRet As Long, cbData As Long
    Dim sKey As String, sValue As String, sBuf As String
    Dim sPath As String
    On Error Resume Next
    sKey = "SOFTWARE\Microsoft\Office\" & CStr(Version) & ".0\Excel\InstallRoot"
    sValue = "Path"
    lRet = RegOpenKeyEx(HKEY_LOCAL_MACHINE, sKey, 0, KEY_QUERY_VALUE, hKey)
    If lRet = ERROR_SUCCESS Then
        sBuf = String(260, Chr(0))
        cbData = Len(sBuf)
        lRet = RegQueryValueEx(hKey, sValue, 0, REG_SZ, sBuf, cbData)
        If lRet = ERROR_SUCCESS Then
            sPath = Left(sBuf, InStr(1, sBuf, Chr(0), 0) - 1)
        End If
        RegCloseKey hKey
    End If
    If Right(sPath, 1) = "\" Then sPath = Left(sPath, Len(sPath) - 1)
    GetExcelPath = sPath
End Function


Function GetExcelApp(ByVal Version As Long) As Object
    Dim sFile As String, sPath As String
    Dim fno As Long, pid As Long
    Dim timeout As Date
    Dim Wb As Object

    On Error GoTo ErrorHandler

    If Version < 8 Then Exit Function

    sFile = ThisWorkbook.Path & "\_dummy.xls"
    sPath = GetExcelPath(Version)
    If sPath = "" Then Exit Function
    sPath = sPath & "\Excel.exe"

    fno = FreeFile()
    Open sFile For Output As #fno
    Close #fno

    pid = Shell("""" & sPath & """ /automation /r """ & sFile & """", _
        vbMinimizedNoFocus)

    timeout = Now() + TimeSerial(0, 0, 10)
    Do While Now() < timeout
        Set Wb = GetObject(sFile)
        If Wb.Application Is Application Then
            Wb.Close False
        Else
            Set GetExcelApp = Wb.Application
            Wb.Close False
            Exit Do
        End If
    Loop
    Set Wb = Nothing

    On Error Resume Next
    Kill sFile
    Exit Function

ErrorHandler:
    Exit Function
End Function


Sub Test_GetExcelApp()
    Dim oApp As Object
    If ThisWorkbook.Path = "" Then Exit Sub
    Set oApp = GetExcelApp(9)
    If Not oApp Is Nothing Then
        MsgBox oApp.Path
        oApp.Quit
        Set oApp = Nothing
    End If
End Sub