www.pudn.com > 档案管理系统源码VB.zip > Register.bas
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