registry.frm

一个对注册表进行操作的VB工程

VERSION 5.00
Begin VB.Form Form1 
   Caption         =   "Registry Functions Demo"
   ClientHeight    =   4515
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   8475
   BeginProperty Font 
      Name            =   "MS Sans Serif"
      Size            =   9.75
      Charset         =   0
      Weight          =   400
      Underline       =   0   'False
      Italic          =   0   'False
      Strikethrough   =   0   'False
   EndProperty
   LinkTopic       =   "Form1"
   ScaleHeight     =   4515
   ScaleWidth      =   8475
   StartUpPosition =   3  'Windows Default
   Begin VB.CommandButton cmdEnumValues 
      Caption         =   "Enum Values"
      Height          =   375
      Left            =   120
      TabIndex        =   6
      Top             =   2640
      Width           =   1695
   End
   Begin VB.ListBox List1 
      Height          =   2940
      Left            =   2040
      Sorted          =   -1  'True
      TabIndex        =   4
      Top             =   240
      Width           =   6255
   End
   Begin VB.CommandButton cmdEnumKeys 
      Caption         =   "Enum Classes"
      Height          =   375
      Left            =   120
      TabIndex        =   3
      Top             =   1920
      Width           =   1695
   End
   Begin VB.CommandButton cmdCreate 
      Caption         =   "Create key/value"
      Height          =   375
      Left            =   120
      TabIndex        =   2
      Top             =   1200
      Width           =   1695
   End
   Begin VB.CommandButton cmdVbSettings 
      Caption         =   "VB Settings"
      Height          =   375
      Left            =   120
      TabIndex        =   1
      Top             =   720
      Width           =   1695
   End
   Begin VB.CommandButton cmdMathProcessor 
      Caption         =   "Math Processor"
      Height          =   375
      Left            =   120
      TabIndex        =   0
      Top             =   240
      Width           =   1695
   End
   Begin VB.Label lblDescription 
      BorderStyle     =   1  'Fixed Single
      Height          =   975
      Left            =   2040
      TabIndex        =   5
      Top             =   3240
      Width           =   6375
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

' True if showing classes.
Dim ShowClass As Boolean

Private Sub cmdMathProcessor_Click()
    MsgBox "Math Processor: " & IIf(MathProcessor, "FOUND", "NOT FOUND"), vbInformation
End Sub

Private Sub cmdVbSettings_Click()
    Dim msg As String
    msg = "FontHeight = " & GetRegistryValue(HKEY_CURRENT_USER, "Software\Microsoft\VBA\Microsoft Visual Basic", "FontHeight", REG_DWORD) & vbCr
    msg = msg & "FontFace = " & GetRegistryValue(HKEY_CURRENT_USER, "Software\Microsoft\VBA\Microsoft Visual Basic", "FontFace", REG_SZ)
    MsgBox msg, vbInformation
End Sub

Private Sub cmdCreate_Click()
    CreateRegistryKey HKEY_CURRENT_USER, "Software\YourCompany"
    MsgBox "Created the HKEY_CURRENT_USER\Software\YourCompany key", vbInformation
    
    CreateRegistryKey HKEY_CURRENT_USER, "Software\YourCompany\YourApplication"
    MsgBox "Created the HKEY_CURRENT_USER\Software\YourCompany\YourApplication key", vbInformation
    
    SetRegistryValue HKEY_CURRENT_USER, "Software\YourCompany\YourApplication", "LastLogin", REG_SZ, FormatDateTime(Now)
    MsgBox "Created the HKEY_CURRENT_USER\Software\YourCompany\YourApplication\LastLogin value", vbInformation
    
    DeleteRegistryValue HKEY_CURRENT_USER, "Software\YourCompany\YourApplication", "LastLogin"
    MsgBox "Deleted the HKEY_CURRENT_USER\Software\YourCompany\YourApplication\LastLogin value", vbInformation
    
    DeleteRegistryKey HKEY_CURRENT_USER, "Software\YourCompany\YourApplication"
    MsgBox "Deleted the HKEY_CURRENT_USER\Software\YourCompany\YourApplication key", vbInformation
    
    DeleteRegistryKey HKEY_CURRENT_USER, "Software\YourCompany"
    MsgBox "Deleted the HKEY_CURRENT_USER\Software\YourCompany key", vbInformation
    
End Sub

Private Sub cmdEnumKeys_Click()
    Dim keys() As String, i As Long
    keys() = EnumRegistryKeys(HKEY_CLASSES_ROOT, "")
    
    ' Filter out a few special items
    For i = LBound(keys) To UBound(keys)
        If Left$(keys(i), 1) = "." Then
            ' these are reserved names.
            keys(i) = vbNullChar
        Else
            ' filter out some non-component names.
            Select Case keys(i)
                Case "*", "CLSID", "AppID", "Component Categories"
                    keys(i) = vbNullChar
            End Select
        End If
    Next
    keys() = Filter(keys(), vbNullChar, False)
    
    List1.Clear
    For i = LBound(keys) To UBound(keys)
        List1.AddItem keys(i)
    Next
    ShowClass = True
  
End Sub

Private Sub List1_Click()
    ' exit if not showing classes.
    If Not ShowClass Then Exit Sub

    Dim clsid As String, descr As String
    Dim key As String, value As String
    
    ' Try to open the CLSID key.
    clsid = GetRegistryValue(HKEY_CLASSES_ROOT, List1.Text & "\CLSID", "", REG_SZ, "")
    If Len(clsid) = 0 Then
        descr = "CLSID not found"
    Else
        descr = "CLSID = " & clsid & vbCrLf
        ' Try to open the InProcServer key.
        key = "CLSID\" & clsid & "\InProcServer32"
        value = GetRegistryValue(HKEY_CLASSES_ROOT, key, "", REG_SZ, "")
        If Len(value) Then
            descr = descr & "InProcServer = " & value & vbCrLf
        End If
        ' Try to open the LocalServer32 key.
        key = "CLSID\" & clsid & "\LocalServer32"
        value = GetRegistryValue(HKEY_CLASSES_ROOT, key, "", REG_SZ, "")
        If Len(value) Then
            descr = descr & "InProcServer = " & value & vbCrLf
        End If
        
    End If
            
    lblDescription = descr
    
End Sub

Private Sub cmdEnumValues_Click()
    Dim values() As Variant, i As Long, descr As String
    values() = EnumRegistryValues(HKEY_CURRENT_USER, "Software\Microsoft\VBA\Microsoft Visual Basic")
    
    List1.Clear
    For i = LBound(values, 2) To UBound(values, 2)
        List1.AddItem values(0, i) & " = " & ValueDescription(values(1, i))
    Next
    ShowClass = False
End Sub

' Convert a value into a printable description.

Private Function ValueDescription(value As Variant) As String
    If VarType(value) = vbLong Then
        ValueDescription = value
    ElseIf VarType(value) = vbString Then
        ValueDescription = """" & value & """"
    ElseIf VarType(value) = vbArray + vbByte Then
        Dim i As Long, buffer As String
        For i = LBound(value) To UBound(value)
            buffer = buffer & Right$("0" & Hex$(value(i)), 2) & " "
        Next
        ValueDescription = buffer
    Else
        ValueDescription = "[ unsupported data type ]"
    End If
        

End Function