Как программно отследить каталог установки AutoCAD?

''''''''''''''''''''''''''''''''''''''''''''''''''''
' Returns the AutoCAD path
''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Function GetAutoCADPath() As String
On Error Resume Next
' Code suggested by Tony Zanzillo
Dim oReg As Object
Dim sVer As String
Dim sPath As String
  Set oReg = CreateObject("WScript.Shell")
  sVer = oReg.RegRead("HKEY_CLASSES_ROOT\AutoCAD.Drawing\CurVer\")
   MsgBox "Current AutoCAD version from AutoCAD.Drawing is " & sVer
  If Err <> 0 Or sVer = "" Then
    Err.Clear
    sVer = oReg.RegRead("HKEY_CLASSES_ROOT\AutoCAD.Application\CurVer\")
  End If
  MsgBox "Current AutoCAD versions is " & sVer
  sPath = oReg.RegRead("HKEY_CLASSES_ROOT\" & sVer & _
                         "\protocol\StdFileEditing\server\")
  If Err <> 0 Or sPath = "" Then
    Err.Clear
    On Error GoTo CantFindAutoCAD
    sVer = Mid$(sVer, InStr(sVer, ".") + 1)
    sVer = "AutoCAD.Drawing." & Mid$(sVer, InStr(sVer, ".") + 1)
    sPath = oReg.RegRead("HKEY_CLASSES_ROOT\" & sVer & _
                         "\protocol\StdFileEditing\server\")
  End If
  MsgBox "and the program filespec is " & sPath
  sPath = Left$(sPath, InStr(sPath, "\acad.ex") - 1)
  MsgBox "and its path is " & sPath
  GetAutoCADPath = sPath
  If sPath <> "" Then
    Exit Function
  End If
CantFindAutoCAD:
  sPath = "Unable to find AutoCAD in the computer registry." & vbCrLf
  sPath = sPath & "Install will not work.  Please read the attached word " _
& "Document "
  sPath = sPath & "for instructions on how to do a manual install"
  MsgBox sPath, vbCritical
End Function  ' GetAutoCADPath
Sub test1()
Call GetAutoCADPath
End Sub
Sub test2()
MsgBox Application.Path
End Sub
Sub test3()
MsgBox Application.FullName
End Sub

Sub Example_FontFileMap()
    ' This example returns the current setting of
    ' FontFileMap. It then changes the value, and finally
    ' it resets the value back to the original setting.
    Dim preferences As AcadPreferences
    Dim currFontFileMap As String
    Dim newFontFileMap As String
    Set preferences = ThisDrawing.Application.preferences
    ' Retrieve the current FontFileMap value
    currFontFileMap = preferences.Files.FontFileMap
    MsgBox "The current value for FontFileMap is " & currFontFileMap, vbInformation, "FontFileMap Example"
    ' Change the value for FontFileMap
    newFontFileMap = "TestFontFileMap.fmp"
    preferences.Files.FontFileMap = newFontFileMap
    MsgBox "The new value for FontFileMap is " & newFontFileMap, vbInformation, "FontFileMap Example"
    ' Reset FontFileMap to its original value
    preferences.Files.FontFileMap = currFontFileMap
    MsgBox "The FontFileMap value is reset to " & currFontFileMap, vbInformation, "FontFileMap Example"
End Sub

(vl-registry-read   (strcat "HKEY_LOCAL_MACHINE\\"
(vlax-product-key))
 "acadlocation")

(findfile "acad.exe")