Полный путь к файлу приложения по названию или связанному расширению

По материалам: https://www.devhut.net/2012/07/10/vba-determine-executable-path-for-given-application/

По названию:

Public Sub test02()
'https://www.devhut.net/2012/07/10/vba-determine-executable-path-for-given-application/
Dim WSHShell
Set WSHShell = CreateObject("WScript.Shell")
'MsgBox WSHShell.RegRead("HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\App Paths\MSACCESS.EXE\")
MsgBox WSHShell.RegRead("HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\App Paths\WINWORD.EXE\")

End Sub

По связанному с приложением расширению:

Прислал Drako: drakopp@ukr.net

Public Function GetAppFullPathByExt(strExtension As String) As String
'Фукция возвращает полный путь связанному приложению по расширению файла
'--------------------------------------------------------------------
'Примеры эксплуатации (Win10x64 + MSO2019x86):
'   Print GetAppFullPathByExt("doc")
'   Вернёт: C:\Program Files (x86)\Microsoft Office\Root\Office16\WINWORD.EXE
'   Print GetAppFullPathByExt("mdb")
'   Вернёт: C:\Program Files (x86)\Microsoft Office\Root\Office16\MSACCESS.EXE
'--------------------------------------------------------------------
Dim WSHShell As Object, s$, sUserChoice$, sUserProg$
On Error GoTo GetAppFullPathByExt_Err

    Set WSHShell = CreateObject("WScript.Shell")
    s = "HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Explorer\FileExts\."
    s = s & strExtension & "\OpenWithList\MRUList"
    sUserChoice = WSHShell.RegRead(s)
    
    s = "HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Explorer\FileExts\."
    s = s & strExtension & "\OpenWithList\" & Left(sUserChoice, 1)
    sUserProg = WSHShell.RegRead(s)
    
    s = "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\App Paths\"
    s = s & sUserProg & "\"
    GetAppFullPathByExt = WSHShell.RegRead(s)
    
    
GetAppFullPathByExt_Bye:
    On Error Resume Next
    Set WSHShell = Nothing
    Err.Clear
    Exit Function

GetAppFullPathByExt_Err:
    MsgBox "Error " & Err.Number & vbCrLf & Err.Description & vbCrLf & _
    "in Function [GetAppFullPathByExt]", vbCritical, "Error!"
    Resume GetAppFullPathByExt_Bye
End Function