wall.bas

通用样品管理系统是一个商业程序,功能界面都还不错!

Attribute VB_Name = "wall"

Option Explicit

Private Declare Function RegOpenKeyEx& Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey&, ByVal lpszSubKey$, dwOptions&, ByVal samDesired&, lpHKey&)
Private Declare Function RegCreateKey& Lib "advapi32" Alias "RegCreateKeyA" (ByVal hKey&, ByVal lpszSubKey$, phkResult&)
Private Declare Function RegCreateKeyEx& Lib "advapi32.dll" Alias "RegCreateKeyExA" (ByVal hKey&, ByVal lpSubKey$, ByVal Reserved&, ByVal lpClass$, ByVal dwOptions&, ByVal samDesired&, lpSecurityAttributes&, phkResult&, lpdwDisposition&)
Private Declare Function RegDeleteKey& Lib "advapi32" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpszSubKey As String)
Private Declare Function RegCloseKey& Lib "advapi32.dll" (ByVal hKey&)
Private Declare Function RegQueryValueEx& Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey&, ByVal lpszValueName$, ByVal lpdwRes&, lpdwType&, ByVal lpDataBuff$, nSize&)
Private Declare Function RegSetValueEx& Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey&, ByVal lpszValueName$, ByVal dwRes&, ByVal dwType&, lpDataBuff As Any, ByVal nSize&)

Const ERROR_SUCCESS = 0&
Const ERROR_BADDB = 1009&
Const ERROR_BADKEY = 1010&
Const ERROR_CANTOPEN = 1011&
Const ERROR_CANTREAD = 1012&
Const ERROR_CANTWRITE = 1013&
Const ERROR_OUTOFMEMORY = 14&
Const ERROR_INVALID_PARAMETER = 87&
Const ERROR_ACCESS_DENIED = 5&
Const ERROR_NO_MORE_ITEMS = 259&
Const ERROR_MORE_DATA = 234&

Const REG_NONE = 0&
Const REG_SZ = 1&
Const REG_EXPAND_SZ = 2&
                                          
Const REG_BINARY = 3&
Const REG_DWORD = 4&
Const REG_DWORD_LITTLE_ENDIAN = 4&
Const REG_DWORD_BIG_ENDIAN = 5&
Const REG_LINK = 6&
Const REG_MULTI_SZ = 7&
Const REG_RESOURCE_LIST = 8&
Const REG_FULL_RESOURCE_DESCRIPTOR = 9&
Const REG_RESOURCE_REQUIREMENTS_LIST = 10&

Const KEY_QUERY_VALUE = &H1&
Const KEY_SET_VALUE = &H2&
Const KEY_CREATE_SUB_KEY = &H4&
Const KEY_ENUMERATE_SUB_KEYS = &H8&
Const KEY_NOTIFY = &H10&
Const KEY_CREATE_LINK = &H20&
Const READ_CONTROL = &H20000
Const WRITE_DAC = &H40000
Const WRITE_OWNER = &H80000
Const SYNCHRONIZE = &H100000
Const STANDARD_RIGHTS_REQUIRED = &HF0000
Const STANDARD_RIGHTS_READ = READ_CONTROL
Const STANDARD_RIGHTS_WRITE = READ_CONTROL
Const STANDARD_RIGHTS_EXECUTE = READ_CONTROL
Const KEY_READ = STANDARD_RIGHTS_READ Or KEY_QUERY_VALUE Or _
KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY
Const KEY_WRITE = STANDARD_RIGHTS_WRITE Or KEY_SET_VALUE Or _
KEY_CREATE_SUB_KEY
Const KEY_EXECUTE = KEY_READ


Public gbSkipRegErrMsg As Boolean

Public Const REG_ERROR = "REGISTRY_ERROR"

Public Function DeleteRegKey(sKeyName As String) As Boolean

 Dim hKey As Long, lRtn As Long
 Dim lMainKeyHandle As Long
     
     DeleteRegKey = False
     
Call ParseKey(sKeyName, lMainKeyHandle)
     
     If lMainKeyHandle Then
        lRtn = RegOpenKeyEx(lMainKeyHandle, sKeyName, 0&, KEY_WRITE, hKey)
     If lRtn = ERROR_SUCCESS Then
        lRtn = RegDeleteKey(hKey, sKeyName)
        lRtn = RegCloseKey(hKey)
        DeleteRegKey = True
     End If
End If

gbSkipRegErrMsg = False

End Function

Private Function GetMainKeyHandle(sMainKeyName As String) As Long

 '系统注册表主键的常量列表
 
  Const HKEY_CLASSES_ROOT = &H80000000
  Const HKEY_CURRENT_USER = &H80000001
  Const HKEY_LOCAL_MACHINE = &H80000002
  Const HKEY_USERS = &H80000003
  Const HKEY_PERFORMANCE_DATA = &H80000004
  Const HKEY_CURRENT_CONFIG = &H80000005
  Const HKEY_DYN_DATA = &H80000006
   
  Select Case sMainKeyName
 
        Case "HKEY_CLASSES_ROOT"
             GetMainKeyHandle = HKEY_CLASSES_ROOT
        Case "HKEY_CURRENT_USER"
             GetMainKeyHandle = HKEY_CURRENT_USER
        Case "HKEY_LOCAL_MACHINE"
             GetMainKeyHandle = HKEY_LOCAL_MACHINE
        Case "HKEY_USERS"
             GetMainKeyHandle = HKEY_USERS
        Case "HKEY_PERFORMANCE_DATA"
             GetMainKeyHandle = HKEY_PERFORMANCE_DATA
        Case "HKEY_CURRENT_CONFIG"
             GetMainKeyHandle = HKEY_CURRENT_CONFIG
        Case "HKEY_DYN_DATA"
             GetMainKeyHandle = HKEY_DYN_DATA
  End Select

End Function

Private Function GetRegError(lErrorCode As Long) As String
    
'注册错误

Select Case lErrorCode
    
    Case 1009, 1015
        GetRegError = "注册表数据据损坏!   "
    Case 2, 1010
        GetRegError = "注册键损坏!    "
    Case 1011
        GetRegError = "不能打开键!    "
    Case 4, 1012
        GetRegError = "不能阅读键!    "
    Case 5
        GetRegError = "访问键时被拒绝!    "
    Case 1013
        GetRegError = "不能写键!    "
    Case 8, 14
        GetRegError = "内存溢出!    "
    Case 87
        GetRegError = "无效的参数!    "
    Case 234
        GetRegError = "比缓冲区更多的数据需要保留!    "
    Case Else
        GetRegError = "未定义的错误代码:    " & Str$(lErrorCode)
End Select

End Function

Private Sub ParseKey(sKeyName As String, lKeyHandle As Long)
   
   Dim nBackSlash As Integer
       nBackSlash = InStr(sKeyName, "\")
       
'分析主键与子键
  If Left(sKeyName, 5) <> "HKEY_" Or Right(sKeyName, 1) = "\" Then
     MsgBox "注册键格式错误 !!!  " & vbCrLf & vbCrLf & sKeyName, vbOKOnly + vbQuestion, "格式错误"
     Exit Sub
  End If
       If nBackSlash = 0 Then
          lKeyHandle = GetMainKeyHandle(sKeyName)
          sKeyName = ""
       Else
          lKeyHandle = GetMainKeyHandle(Left(sKeyName, nBackSlash - 1))
          sKeyName = Right(sKeyName, Len(sKeyName) - nBackSlash)
       End If

   If lKeyHandle < &H80000000 Or lKeyHandle > &H80000006 Then
      MsgBox " 无效的主键句柄 !    ", vbOKOnly + vbExclamation, "句柄错误"
   End If

End Sub

Public Function GetRegStringValue(sSubKey As String, sEntry As String) As String

  Dim hKey As Long, lMainKeyHandle As Long
  Dim lRtn As Long, sBuffer As String
  Dim lBufferSize As Long, lType As Long
  Dim sErrMsg As String

      lType = REG_SZ
      GetRegStringValue = REG_ERROR

      Call ParseKey(sSubKey, lMainKeyHandle)

If lMainKeyHandle Then

    lRtn = RegOpenKeyEx(lMainKeyHandle, sSubKey, 0&, KEY_READ, hKey)
    
    If lRtn = ERROR_SUCCESS Then
        '请求键值
        sBuffer = Space(255)
        lBufferSize = Len(sBuffer)
        lRtn = RegQueryValueEx(hKey, sEntry, 0&, lType, sBuffer, lBufferSize)
        
        If lRtn = ERROR_SUCCESS Then
           lRtn = RegCloseKey(hKey)
            '除去后面的空串
            sBuffer = Trim(sBuffer)
            GetRegStringValue = Left(sBuffer, Len(sBuffer) - 1)
        Else
        
           
        End If
    Else
    End If
End If

gbSkipRegErrMsg = False

End Function

Public Function WriteRegStringValue(sSubKey As String, sEntry As String, sValue As String) As Boolean

   Dim hKey As Long, lMainKeyHandle As Long
   Dim lRtn As Long, lDataSize As Long
   Dim lType As Long, sErrMsg As String

   WriteRegStringValue = False

   lType = REG_SZ

   Call ParseKey(sSubKey, lMainKeyHandle)

If lMainKeyHandle Then
    '打开注册键
    lRtn = RegOpenKeyEx(lMainKeyHandle, sSubKey, 0&, KEY_WRITE, hKey)
    If lRtn = ERROR_SUCCESS Then
        '写键值
        lDataSize = Len(sValue)
        lRtn = RegSetValueEx(hKey, sEntry, 0&, lType, ByVal sValue, lDataSize)
        
        If lRtn = ERROR_SUCCESS Then
            WriteRegStringValue = True
        Else
        End If
        lRtn = RegCloseKey(hKey)
    Else
    End If
End If

gbSkipRegErrMsg = False

End Function

Public Function CreateRegKey(sSubKey As String) As Boolean

    Dim lMainKeyHandle As Long, hKey As Long
    Dim sErrMsg As String, lRtn As Long

    CreateRegKey = False

    Call ParseKey(sSubKey, lMainKeyHandle)

'建立子键
If lMainKeyHandle Then
    lRtn = RegCreateKey(lMainKeyHandle, sSubKey, hKey)
    If lRtn = ERROR_SUCCESS Then
        '建立完成,关闭
        lRtn = RegCloseKey(hKey)
        CreateRegKey = True
    Else
        If Not gbSkipRegErrMsg Then
           sErrMsg = GetRegError(lRtn)
           MsgBox sErrMsg, vbCritical, "建立子键错误"
        End If
    End If
End If

gbSkipRegErrMsg = False

End Function