vbreg.bas

使用modem实现的来电显示程序,可以用参考串口编程

Attribute VB_Name = "注册簿管理"
Option Explicit
Private Const KEY_QUERY_VALUE = &H1
Private Const KEY_SET_VALUE = &H2
Private Const KEY_CREATE_SUB_KEY = &H4
Private Const KEY_ENUMERATE_SUB_KEYS = &H8
Private Const KEY_NOTIFY = &H10
Private Const KEY_CREATE_LINK = &H20
Private Const KEY_ALL_ACCESS = &H3F

'Open/Create Options
Private Const REG_OPTION_NON_VOLATILE = 0&
Private Const REG_OPTION_VOLATILE = &H1

'Key creation/open disposition
Private Const REG_CREATED_NEW_KEY = &H1
Private Const REG_OPENED_EXISTING_KEY = &H2

'masks for the predefined standard access types
Private Const STANDARD_RIGHTS_ALL = &H1F0000
Private Const SPECIFIC_RIGHTS_ALL = &HFFFF

'Define severity codes
Private Const ERROR_SUCCESS = 0&
Private Const ERROR_ACCESS_DENIED = 5
Private Const ERROR_INVALID_DATA = 13&
Private Const ERROR_MORE_DATA = 234 '  dderror
Private Const ERROR_NO_MORE_ITEMS = 259


'Structures Needed For Registry Prototypes
Private Type SECURITY_ATTRIBUTES
  nLength As Long
  lpSecurityDescriptor As Long
  bInheritHandle As Boolean
End Type

Private Type FILETIME
  dwLowDateTime As Long
  dwHighDateTime As Long
End Type

'Registry Function Prototypes
Private Declare Function RegOpenKeyEx Lib "advapi32" Alias "RegOpenKeyExA" _
  (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, _
  ByVal samDesired As Long, phkResult As Long) As Long

Private Declare Function RegSetValueExStr Lib "advapi32" Alias "RegSetValueExA" _
  (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, _
   ByVal dwType As Long, ByVal szData As String, ByVal cbData As Long) As Long
Private Declare Function RegSetValueExLong Lib "advapi32" Alias "RegSetValueExA" _
  (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, _
   ByVal dwType As Long, szData As Long, ByVal cbData As Long) As Long
Private Declare Function RegSetValueExByte Lib "advapi32" Alias "RegSetValueExA" _
  (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, _
   ByVal dwType As Long, szData As Byte, ByVal cbData As Long) As Long

Private Declare Function RegCloseKey Lib "advapi32" (ByVal hKey As Long) As Long

Private Declare Function RegQueryValueExStr Lib "advapi32" Alias "RegQueryValueExA" _
  (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, _
   ByRef lpType As Long, ByVal szData As String, ByRef lpcbData As Long) As Long
Private Declare Function RegQueryValueExLong Lib "advapi32" Alias "RegQueryValueExA" _
  (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, _
   ByRef lpType As Long, szData As Long, ByRef lpcbData As Long) As Long
Private Declare Function RegQueryValueExByte Lib "advapi32" Alias "RegQueryValueExA" _
  (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, _
   ByRef lpType As Long, szData As Byte, ByRef lpcbData As Long) As Long
   
Private Declare Function RegCreateKeyEx Lib "advapi32" Alias "RegCreateKeyExA" _
  (ByVal hKey As Long, ByVal lpSubKey As String, ByVal Reserved As Long, _
   ByVal lpClass As String, ByVal dwOptions As Long, ByVal samDesired As Long, _
   lpSecurityAttributes As SECURITY_ATTRIBUTES, phkResult As Long, _
   lpdwDisposition As Long) As Long

Private Declare Function RegEnumKeyEx Lib "advapi32.dll" Alias "RegEnumKeyExA" _
  (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpName As String, _
   lpcbName As Long, ByVal lpReserved As Long, ByVal lpClass As String, _
   lpcbClass As Long, lpftLastWriteTime As FILETIME) As Long

Private Declare Function RegEnumKey Lib "advapi32.dll" Alias "RegEnumKeyA" ( _
    ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpName As String, _
    ByVal cbName As Long) As Long

Private Declare Function RegEnumValue Lib "advapi32.dll" Alias "RegEnumValueA" _
  (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpValueName As String, _
   lpcbValueName As Long, ByVal lpReserved As Long, ByVal lpType As Long, _
   ByVal lpData As Long, ByVal lpcbData As Long) As Long
   
Private Declare Function RegEnumValueLong Lib "advapi32.dll" Alias "RegEnumValueA" _
  (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpValueName As String, _
   lpcbValueName As Long, ByVal lpReserved As Long, lpType As Long, _
   lpData As Long, lpcbData As Long) As Long
Private Declare Function RegEnumValueStr Lib "advapi32.dll" Alias "RegEnumValueA" _
  (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpValueName As String, _
   lpcbValueName As Long, ByVal lpReserved As Long, lpType As Long, _
   ByVal lpData As String, lpcbData As Long) As Long
Private Declare Function RegEnumValueByte Lib "advapi32.dll" Alias "RegEnumValueA" _
  (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpValueName As String, _
   lpcbValueName As Long, ByVal lpReserved As Long, lpType As Long, _
   lpData As Byte, lpcbData As Long) As Long

Private Declare Function RegQueryInfoKey Lib "advapi32.dll" Alias "RegQueryInfoKeyA" _
   (ByVal hKey As Long, ByVal lpClass As String, _
   lpcbClass As Long, ByVal lpReserved As Long, lpcSubKeys As Long, _
   lpcbMaxSubKeyLen As Long, lpcbMaxClassLen As Long, lpcValues As Long, _
   lpcbMaxValueNameLen As Long, lpcbMaxValueLen As Long, lpcbSecurityDescriptor As Long, _
   lpftLastWriteTime As Any) As Long

Private Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" _
  (ByVal hKey As Long, ByVal lpSubKey As String) As Long

Private Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" _
  (ByVal hKey As Long, ByVal lpValueName As String) As Long

' Other declares:
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
    lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)
Private Declare Function ExpandEnvironmentStrings Lib "kernel32" Alias "ExpandEnvironmentStringsA" (ByVal lpSrc As String, ByVal lpDst As String, ByVal nSize As Long) As Long


Public Enum ERegistryClassConstants
    HKEY_CLASSES_ROOT = &H80000000
    HKEY_CURRENT_USER = &H80000001
    HKEY_LOCAL_MACHINE = &H80000002
    HKEY_USERS = &H80000003
End Enum

Public Enum ERegistryValueTypes
'Predefined Value Types
    REG_NONE = (0)                         'No value type
    REG_SZ = (1)                           'Unicode nul terminated string
    REG_EXPAND_SZ = (2)                    'Unicode nul terminated string w/enviornment var
    REG_BINARY = (3)                       'Free form binary
    REG_DWORD = (4)                        '32-bit number
    REG_DWORD_LITTLE_ENDIAN = (4)          '32-bit number (same as REG_DWORD)
    REG_DWORD_BIG_ENDIAN = (5)             '32-bit number
    REG_LINK = (6)                         'Symbolic Link (unicode)
    REG_MULTI_SZ = (7)                     'Multiple Unicode strings
    REG_RESOURCE_LIST = (8)                'Resource list in the resource map
    REG_FULL_RESOURCE_DESCRIPTOR = (9)     'Resource list in the hardware description
    REG_RESOURCE_REQUIREMENTS_LIST = (10)
End Enum


Private Const HKEYMAIN = HKEY_LOCAL_MACHINE
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Public Declare Function SendMessageVal Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Public Declare Function SendMessageStr Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As Long


Public Declare Function RegSetValue Lib "advapi32.dll" Alias "RegSetValueA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal dwType As Long, ByVal lpData As String, ByVal cbData As Long) As Long
Public Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As Long         ' Note that if you declare the lpData parameter as String, you must pass it By Value.

Public Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long         ' Note that if you declare the lpData parameter as String, you must pass it By Value.

' 函数名: DeleteKey
'-----------------------------------------------------
' 创建: 1997-10-22   By: 陈安军
' 修改:              By:
'=====================================================
'从Registy 中读删除串值
'
'Key       关键字
    ' 例 software\FK\COMM\settings 中
    'software\FK\COMM\ 为主键
    'settings 为配置
''
Sub DeleteKey(ByVal Key As String)
Dim hKey()  As Long, lResult As Long
Dim i       As Integer
Dim dx      As Integer
ReDim hKey(0)

    hKey(0) = HKEYMAIN
    i = 0
    dx = InStr(Key$, "\")
    Do While dx <> 0
        ReDim Preserve hKey(UBound(hKey) + 1)
        lResult = RegOpenKeyEx(hKey(i), Mid(Key$, 1, dx - 1), 0, KEY_ALL_ACCESS, hKey(i + 1))
        '递归打开键值
        If hKey(i + 1) = 0 Then     '不存在此键值时返回
            GoTo DeleteToExit
        End If
        i = i + 1
        Key$ = Mid(Key$, dx + 1)
        dx = InStr(Key$, "\")
    Loop
    '存在键值时删除
    If Key <> "" Then RegDeleteKey hKey(i), Key
'关闭主键
DeleteToExit:
    For i = UBound(hKey) To 1 Step -1
        If hKey(i) <> 0 Then RegCloseKey hKey(i)
    Next i
End Sub
Sub EnumMainKey(Key As String, sKey() As String)
Dim hKey()      As Long, lResult As Long
Dim lpName      As String, lnName As Long
Dim lpClass     As String, lnClass As Long
Dim lpftLastWriteTime As FILETIME
Dim i           As Integer
Dim dx          As Integer
Dim lpresult    As Long
ReDim sKey(0)
    ReDim hKey(0)
    Dim dwIndex As Long
    hKey(0) = HKEYMAIN
    i = 0
    dx = InStr(Key$, "\")
    Do While dx <> 0
        ReDim Preserve hKey(UBound(hKey) + 1)
        lResult = RegOpenKeyEx(hKey(i), Mid(Key$, 1, dx - 1), 0, KEY_ALL_ACCESS, hKey(i + 1))
        '递归打开键值
        If hKey(i + 1) = 0 Then     '不存在此键值时返回
            GoTo DeleteToExit
        End If
        i = i + 1
        Key$ = Mid(Key$, dx + 1)
        dx = InStr(Key$, "\")
    Loop
    '存在键值时删除
    dwIndex = 0
    
    Dim pKey    As String
    Dim k       As Integer
    Dim pi      As Integer
    Dim ft      As FILETIME
    Do
        lpName = Space(250)
        lnName = 250
        lpClass = Space(250)
        lnClass = 250
        'lpresult = RegEnumValue(hKey(i), dwIndex, lpName, lnName, 0, REG_SZ, StrPtr(lpClass), lnClass)
        lpresult = RegEnumKeyEx(hKey(i), dwIndex, lpName, lnName, 0, StrPtr(lpClass), lnClass, ft)
        If lpresult = 0 Then
            If lnName <> 0 Then
                ReDim Preserve sKey(UBound(sKey) + 1)
                sKey(UBound(sKey)) = Mid(lpName, 1, InStr(lpName, Chr(0)) - 1)
            End If
        End If
        dwIndex = dwIndex + 1
    Loop Until lpresult = ERROR_NO_MORE_ITEMS
'关闭主键
DeleteToExit:
    For i = UBound(hKey) To 1 Step -1
        If hKey(i) <> 0 Then RegCloseKey hKey(i)
    Next i
End Sub
' 函数名: EnumKey
'-----------------------------------------------------
' 创建: 1997-10-22   By: 陈安军
' 修改:              By:
'=====================================================
'枚举关键字
'
'Key       关键字
    ' 例 software\FK\ 中
    'software\FK\ 为主键
'
Sub EnumKey(Key As String)
Dim hKey()  As Long, lResult As Long
Dim lpName  As String, lnName As Long
Dim lpClass As String, lnClass As Long
Dim lpftLastWriteTime As FILETIME
Dim i       As Integer
Dim dx      As Integer
Dim lpresult    As Long
    ReDim hKey(0)
    Dim dwIndex As Long
    hKey(0) = HKEYMAIN
    i = 0
    dx = InStr(Key$, "\")
    Do While dx <> 0
        ReDim Preserve hKey(UBound(hKey) + 1)
        lResult = RegOpenKeyEx(hKey(i), Mid(Key$, 1, dx - 1), 0, KEY_ALL_ACCESS, hKey(i + 1))
        '递归打开键值
        If hKey(i + 1) = 0 Then     '不存在此键值时返回
            GoTo DeleteToExit
        End If
        i = i + 1
        Key$ = Mid(Key$, dx + 1)
        dx = InStr(Key$, "\")
    Loop
    '存在键值时删除
    lpName = Space(50)
    lnName = 50
    lpClass = Space(50)
    lnClass = 50
    dwIndex = 0
    Do
        lpresult = RegEnumKeyEx(hKey(i), dwIndex, lpName, lnName, 0, lpClass, lnClass, lpftLastWriteTime)
        dwIndex = dwIndex + 1
    Loop Until lpresult = ERROR_NO_MORE_ITEMS
'关闭主键
DeleteToExit:
    For i = UBound(hKey) To 1 Step -1
        If hKey(i) <> 0 Then RegCloseKey hKey(i)
    Next i
    
End Sub

' 函数名: EnumValue
'-----------------------------------------------------
' 创建: 1997-10-22   By: 陈安军
' 修改:              By:
'=====================================================
'枚举关键字
'
'Key       关键字
    ' 例 software\FK\ 中
    'software\FK\ 为主键
''
Sub EnumValue(Key As String)
Dim hKey() As Long, lResult As Long
Dim lpName As String, lnName As Long
Dim lpClass As String, lnClass As Long
Dim lpftLastWriteTime As FILETIME
Dim i   As Integer
Dim dx  As Integer
Dim lpresult    As Long