Visual Basic Programmer'…arterly (Limited Edition)/Visual_Basic_Programmers_Journal_VB-CD_Quarterly_Limited_Edition_1995.iso/code/ch16code/verify.bas

BASIC Source File | 1995-08-12 | 6.6 KB | 208 lines

Attribute VB_Name = "Module1"
Option Explicit
' Registration APIs used to check entry.
#If Win16 Then
Declare Function RegOpenKey Lib "Shell" _
    (ByVal HKeyIn As Long, _
    ByVal LPCSTR As String, _
    HKeyOut As Long) _
    As Long
Declare Function RegCloseKey Lib "Shell" _
    (ByVal HKeyIn As Long) _
    As Long
Declare Function RegEnumKey Lib "Shell" _
    (ByVal HKeyIn As Long, ByVal SubKeyIn As Long, _
    ByVal KeyName As String, ByVal KeyNameLen As Long) As Long
Declare Function RegQueryValue Lib "Shell" _
    (ByVal HKeyIn As Long, _
    ByVal SubKey As String, _
    ByVal KeyValue As String, _
    KeyValueLen As Long) _
    As Long
Declare Function RegSetValue Lib "Shell" _
    (ByVal HKeyIn As Long, _
    ByVal SubKey As String, _
    ByVal lType As Long, _
    ByVal strNewValue As String, _
    ByVal lIngnored As Long) _
    As Long
Declare Sub RegDeleteKey Lib "Shell" _
    (ByVal HKeyIn As Long, _
    ByVal SubKeyName As String)
#Else
Declare Function RegOpenKey Lib "advapi32" _
    Alias "RegOpenKeyA" _
    (ByVal HKeyIn As Long, _
    ByVal LPCSTR As String, _
    HKeyOut As Long) _
    As Long
Declare Function RegOpenKeyEx Lib "advapi32" _
    Alias "RegOpenKeyExA" _
    (ByVal HKeyIn As Long, ByVal LPCSTR _
    As String, ByVal dwRes _
    As Long, ByVal dwAccess _
    As Long, HKeyOut As _
    Long) As Long
Declare Function RegCloseKey Lib "advapi32" _
    (ByVal HKeyIn As Long) _
    As Long
Private Declare Function RegEnumKey Lib "advapi32" _
    Alias "RegEnumKeyA" _
    (ByVal hKey As Long, _
    ByVal dwIndex As Long, _
    ByVal lpName As String, _
    ByVal cbName As Long) _
    As Long
Declare Function RegQueryValue Lib "advapi32" _
    Alias "RegQueryValueA" _
    (ByVal HKeyIn As Long, _
    ByVal SubKey As String, _
    ByVal KeyValue As String, _
    KeyValueLen As Long) _
    As Long
Declare Function RegSetValue Lib "advapi32" _
    Alias "RegSetValueA" _
    (ByVal HKeyIn As Long, _
    ByVal SubKey As String, _
    ByVal lType As Long, _
    ByVal strNewValue As String, _
    ByVal lIngnored As Long) _
    As Long
Declare Function RegDeleteKey Lib "advapi32" _
    Alias "RegDeleteKeyA" _
    (ByVal HKeyIn As Long, _
    ByVal SubKeyName As String) _
    As Long
#End If

#If Win16 Then
    Const HKEY_CLASSES_ROOT = &H1
#Else
    Const HKEY_CLASSES_ROOT = &H80000000
    Const HKEY_CURRENT_USER = &H80000001
    Const HKEY_LOCAL_MACHINE = &H80000002
    Const HKEY_USERS = &H80000003
    Const HKEY_PERFORMANCE_DATA = &H80000004
#End If

Public Const ERROR_SUCCESS = 0



Sub Main()
    Dim strNotFound As String
    Dim bWorked As Boolean
    bWorked = CheckInstalled(Array("Microsoft Excel", "Microsoft Word"), strNotFound)
    If bWorked Then
        ' All required applications available -- continue.
    Else
        MsgBox "The following required applications were not found: " & strNotFound
    End If
End Sub

Function CheckInstalled(RequiredList, strNotFound As String) As Variant
    Dim InstalledList As Variant
    Dim InstalledName, RequiredName
    Dim bFound As Boolean
    Dim AppName As String
    InstalledList = GetRegisteredList()
    For Each RequiredName In RequiredList
        For Each InstalledName In InstalledList
            If InStr(InstalledName, RequiredName) Then
                bFound = True
                Exit For
            End If
            bFound = False
        Next InstalledName
        ' Build list of application that weren't found.
        If bFound = False Then
            strNotFound = strNotFound & ", " & RequiredName
        End If
    Next RequiredName
    If Len(strNotFound) Then
        strNotFound = Right(strNotFound, Len(strNotFound) - 2)
        CheckInstalled = False
    Else
        CheckInstalled = True
        strNotFound = ""
    End If
End Function

Function GetRegisteredList() As Variant
    Dim hkroot As Long, x As Long, lLen As Long
    ReDim Installed(99)
    Dim strKeyID As String * 80, strKeyDesc As String * 80, iKeyCount As Integer
    x = RegOpenKey(HKEY_CLASSES_ROOT, "", hkroot)
    lLen = 255
    Do
        strKeyID = String(lLen, 0)
        If RegEnumKey(hkroot, iKeyCount, strKeyID, lLen) = 0 Then
            lLen = 255
            ' If the string is not a file extension (.doc, .xls, etc.)
            If Mid(strKeyID, 1, 1) <> "." Then
                strKeyDesc = String(lLen, 0)
                ' Get the value of the registry entry.
                x = RegQueryValue(hkroot, strKeyID, strKeyDesc, lLen)
                Installed(iKeyCount) = strKeyDesc
                lLen = 255
            End If
            iKeyCount = iKeyCount + 1
            If iKeyCount > UBound(Installed) Then
                ' Add elements if the array gets full.
                ReDim Preserve Installed(UBound(Installed) + 100)
            End If
        Else
            Exit Do
        End If
    Loop
    ' Trim off excess array elements.
    ReDim Preserve Installed(iKeyCount)
    x = RegCloseKey(hkroot)
    GetRegisteredList = Installed
End Function

Function sTrim(sIn) As String
    Dim iCount As Integer
    For iCount = Len(sIn) To 1 Step -1
        If Asc(Mid$(sIn, iCount, iCount)) <> 0 Then
            sTrim = Mid$(sIn, 1, iCount)
            Exit Function
        End If
    Next iCount
End Function

Function GetRegisteredKeys(Optional sKeyName As Variant) As Variant
    Dim hkroot As Long, x As Long, lLen As Long
    Dim strKeyID As String * 80, strKeyDesc As String * 80, iKeyCount As Integer
    ReDim KeyArray(1, 1) As String
    If IsMissing(sKeyName) Then sKeyName = ""
    x = RegOpenKey(HKEY_CLASSES_ROOT, sKeyName, hkroot)
    lLen = 80
    Do
        strKeyID = String(lLen, 0)
        If RegEnumKey(hkroot, iKeyCount, strKeyID, lLen) = 0 Then
            lLen = 80
            If Mid(strKeyID, 1, 1) <> "." Then
                KeyArray(iKeyCount, 0) = sTrim(strKeyID)
                strKeyDesc = String(lLen, 0)
                x = RegQueryValue(hkroot, strKeyID, strKeyDesc, lLen)
                lLen = 80
                KeyArray(iKeyCount, 1) = sTrim(strKeyDesc)
            End If
            iKeyCount = iKeyCount + 1
            ' Reserve more space for the array.
            If iKeyCount > UBound(KeyArray, 1) Then
                ReDim Preserve KeyArray(iKeyCount + 100, iKeyCount + 100)
            End If
        Else
            Exit Do
        End If
    Loop
    x = RegCloseKey(hkroot)
    ' Trim off excess from array
    If iKeyCount <= UBound(KeyArray, 1) Then
        ReDim Preserve KeyArray(iKeyCount - 1, iKeyCount - 1)
    End If
    GetRegisteredKeys = KeyArray
End Function