register.bas

档案管理系统源码VB档案管理系统源码VB

Attribute VB_Name = "Bas"
Option Explicit

Public Const NIM_ADD = &H0
Public Const NIM_DELETE = &H2
Public Const WM_MOUSEMOVE = &H200
Public Const NIF_MESSAGE = &H1
Public Const NIF_TIP = &H4
Public Const REG_ERROR = "REGISTRY_ERROR"
Public Const NIM_MODIFY = &H1
Public Const NIF_ICON = &H2
Public Const WM_LBUTTONDOWN As Long = &H201
Public Const WM_LBUTTONUP As Long = &H202
Public Const WM_LBUTTONDBLCLK As Long = &H203
Public Const WM_MBUTTONDOWN As Long = &H207
Public Const WM_MBUTTONUP As Long = &H208
Public Const WM_MBUTTONDBLCLK As Long = &H209
Public Const WM_RBUTTONDOWN As Long = &H204
Public Const WM_RBUTTONUP As Long = &H205
Public Const WM_RBUTTONDBLCLK As Long = &H206

Type FILETIME
    lLowDateTime    As Long
    lHighDateTime   As Long
End Type

Public Type NOTIFYICONDATA
    cbSize As Long
    hwnd As Long
    uID As Long
    uFlags As Long
    uCallbackMessage As Long
    hIcon As Long
    szTip As String * 64
End Type


Public T As NOTIFYICONDATA

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

Declare Function RegConnectRegistry& Lib "advapi32.dll" (ByVal lpMachineName$, ByVal hKey&, phkResult&)
Declare Function RegFlushKey& Lib "advapi32.dll" (ByVal hKey&)
Declare Function RegEnumKeyEx& Lib "advapi32.dll" Alias "RegEnumKeyExA" (ByVal hKey&, ByVal dwIndex&, ByVal lpName$, lpcbName&, ByVal lpReserved&, ByVal lpClass$, lpcbClass&, lpftLastWriteTime As FILETIME)
Declare Function RegEnumValue& Lib "advapi32.dll" Alias "RegEnumValueA" (ByVal hKey&, ByVal dwIndex&, ByVal lpName$, lpcbName&, ByVal lpReserved&, lpdwType&, lpValue As Any, lpcbValue&)
Declare Function RegQueryInfoKey& Lib "advapi32.dll" Alias "RegQueryInfoKeyA" (ByVal hKey&, ByVal lpClass$, lpcbClass&, ByVal lpReserved&, lpcSubKeys&, lpcbMaxSubKeyLen&, lpcbMaxClassLen&, lpcValues&, lpcbMaxValueNameLen&, lpcbMaxValueLen&, lpcbSecurityDescriptor&, lpftLastWriteTime As FILETIME)
Declare Function Shell_NotifyIcon Lib "shell32" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, pnid As NOTIFYICONDATA) As Boolean
Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long

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 DRIVE_CDROM = 5
Public NotifyTrue As Boolean, PlayTrue As Boolean


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
        
            If gbSkipRegErrMsg = False Then
                sErrMsg = GetRegError(lRtn)
                MsgBox sErrMsg + "    ", vbCritical, "请求注册键值错误!"
            End If
            
        End If
    Else
        If Not gbSkipRegErrMsg Then
            sErrMsg = GetRegError(lRtn)
            MsgBox sErrMsg, vbCritical, "注册键打开错误!"
        End If
    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
           If Not gbSkipRegErrMsg Then
              sErrMsg = GetRegError(lRtn)
              MsgBox sErrMsg, vbCritical, "写注册键值时错误"
            End If
        End If
        lRtn = RegCloseKey(hKey)
    Else
        If Not gbSkipRegErrMsg Then
            sErrMsg = GetRegError(lRtn)
            MsgBox sErrMsg, vbCritical, "注册键打开错误"
        End If
    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

Public Function FirstCDDrive() As String

 Const ASC_A = 65
 Const ASC_Z = ASC_A + 25

 Dim i As Integer

    For i = ASC_A To ASC_Z
        If GetDriveType(Chr$(i) & ":\") = DRIVE_CDROM Then
            FirstCDDrive = Chr$(i)
            Exit For
        End If
    Next i
    
End Function