Zjištění nainstalovaných součástí Office

Option Explicit
Private Declare Function RegOpenKey Lib "advapi32" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, lpReserved As Long, lptype As Long, lpData As Any, lpcbData As Long) As Long
Private Declare Function RegCloseKey& Lib "advapi32" (ByVal hKey&)

Private Const REG_SZ = 1
Private Const REG_EXPAND_SZ = 2
Private Const ERROR_SUCCESS = 0
Private Const HKEY_CLASSES_ROOT = &H80000000

Function FileExists(sFileName$) As Boolean
    On Error Resume Next
    FileExists = IIf(Dir(Trim(sFileName)) <> "", True, False)
End Function

Public Function IsAppPresent(strSubKey$, strValueName$) As Boolean
    IsAppPresent = CBool(Len(GetRegString (HKEY_CLASSES_ROOT, strSubKey, strValueName)))
End Function

Public Function GetRegString(hKey As Long, strSubKey As String, strValueName As String) As String
    Dim strSetting As String
    Dim lngDataLen As Long
    Dim lngRes As Long
    If RegOpenKey(hKey, strSubKey, lngRes) = ERROR_SUCCESS Then
       strSetting = Space(255)
       lngDataLen = Len(strSetting)
       If RegQueryValueEx(lngRes, strValueName, ByVal 0, REG_EXPAND_SZ, ByVal strSetting, lngDataLen) = ERROR_SUCCESS Then
          If lngDataLen > 1 Then
             GetRegString = Left(strSetting, lngDataLen - 1)
          End If
       End If
       If RegCloseKey(lngRes) <> ERROR_SUCCESS Then
           MsgBox "RegCloseKey selhalo: " & strSubKey, vbCritical
       End If
    End If
End Function

Na událost Click tlačítka:

Private Sub Command1_Click()

    Label1.Caption = "Access " & IsAppPresent("Access.Database\CurVer", "")
    Label2.Caption = "Excel " & IsAppPresent("Excel.Sheet\CurVer", "")
    Label3.Caption = "PowerPoint " & IsAppPresent("PowerPoint.Slide\CurVer", "")
    Label4.Caption = "Word " & IsAppPresent("Word.Document\CurVer", "")

End Sub

Zpět