在VB中怎样判断系统中是否安装ACCESS?, - Office中国论坛/Access中国论坛

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_EXPAND_SZ = 2
Private Const ERROR_SUCCESS = 0
Private Const HKEY_CLASSES_ROOT = &H80000000
Public Function IsAppPresent(ByVal strSubKey$) As Boolean
IsAppPresent = CBool(Len(GetRegString(HKEY_CLASSES_ROOT, strSubKey)))
End Function
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
Public Function GetRegString(ByVal hKey As Long, _
ByVal strSubKey As String) As String
Dim strSetting As String
Dim lngDataLen As Long
Dim lnghResult As Long
If RegOpenKey(hKey, strSubKey, lnghResult) = ERROR_SUCCESS Then
strSetting = Space$(255)
lngDataLen = Len(strSetting)
'lpValueName为vbNullString只读取其默认值
If RegQueryValueEx(lnghResult, vbNullString, 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(lnghResult) <> ERROR_SUCCESS Then
MsgBox "RegCloseKey Failed: " & strSubKey, vbCritical
End If
End If
End Function

复制代码