regclass.cls

星级酒店管理系统（附带系统自写控件源码）

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "RegClass"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Attribute VB_Ext_KEY = "SavedWithClassBuilder6" ,"Yes"
Attribute VB_Ext_KEY = "Top_Level" ,"Yes"

Option Explicit

Private Type FILETIME
    lLowDateTime    As Long
    lHighDateTime   As Long
End Type

'置顶层
Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long

Private Const SWP_NOMOVE = &H2
Private Const SWP_NOSIZE = &H1
Private Const HWND_TOPMOST = -1
Private Const HWND_NOTOPMOST = -2

Private Declare Function GetCurrentProcessId Lib "kernel32" () As Long
Private Declare Function GetCurrentProcess Lib "kernel32" () As Long
Private Declare Function RegisterServiceProcess Lib "kernel32" (ByVal dwProcessID As Long, ByVal dwType As Long) As Long

Private Const RSP_SIMPLE_SERVICE = 1 '注册为服务程序
Private Const RSP_UNREGISTER_SERVICE = 0  '取消
 
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&)
Private Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String) As Long

Private Declare Function RegConnectRegistry& Lib "advapi32.dll" (ByVal lpMachineName$, ByVal hKey&, phkResult&)
Private Declare Function RegFlushKey& Lib "advapi32.dll" (ByVal hKey&)
Private Declare Function RegEnumKeyEx& Lib "advapi32.dll" Alias "RegEnumKeyExA" (ByVal hKey&, ByVal dwIndex&, ByVal lpName$, lpcbName&, ByVal lpReserved&, ByVal lpClass$, lpcbClass&, lpftLastWriteTime As FILETIME)
Private Declare Function RegEnumValue& Lib "advapi32.dll" Alias "RegEnumValueA" (ByVal hKey&, ByVal dwIndex&, ByVal lpName$, lpcbName&, ByVal lpReserved&, lpdwType&, lpValue As Any, lpcbValue&)
Private 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)

'写入或给出自己Ini文件内容
Private Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
Private Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Long
Private Declare Function GetPrivateProfileSection& Lib "kernel32" Alias "GetPrivateProfileSectionA" (ByVal lpAppName As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String)
Private Declare Function GetPrivateProfileInt& Lib "kernel32" Alias "GetPrivateProfileIntA" (ByVal lpApplicationName As String, ByVal lpKeyName As String, ByVal nDefault As Long, ByVal lpFileName As String)

'写入或给出Win.ini
Private Declare Function WriteProfileString Lib "kernel32" Alias "WriteProfileStringA" (ByVal lpszSection As String, ByVal lpszKeyName As String, ByVal lpszString As String) As Long
Private Declare Function WriteProfileSection Lib "kernel32" Alias "WriteProfileSectionA" (ByVal lpAppName As String, ByVal lpString As String) As Long
Private Declare Function GetProfileInt Lib "kernel32" Alias "GetProfileIntA" (ByVal lpAppName As String, ByVal lpKeyName As String, ByVal nDefault As Long) As Long
Private Declare Function GetProfileSection Lib "kernel32" Alias "GetProfileSectionA" (ByVal lpAppName As String, ByVal lpReturnedString As String, ByVal nSize As Long) As Long
Private Declare Function GetProfileString Lib "kernel32" Alias "GetProfileStringA" (ByVal lpAppName As String, ByVal lpKeyName As String, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long) 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

Private gbSkipRegErrMsg As Boolean

Private Const REG_ERROR = "REGISTRY_ERROR"
Private Declare Function DeleteMenu Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long
Private Declare Function GetSystemMenu Lib "user32" (ByVal hwnd As Long, ByVal bRevert As Long) As Long

Private Const MF_BYPOSITION = &H0&

Private Const SC_CLOSE = &HF060&
Private Const SC_MAXIMIZE = &HF030&
Private Const SC_MINIMIZE = &HF020&
Private Const SC_MOVE = &HF010&
Private Const SC_RESTORE = &HF120&
Private Const SC_SIZE = &HF000&

Private ReadyToClose As Boolean

Public Sub SetNoTopLay(lHwnd As Long)

  Dim retVal As Long
  retVal = SetWindowPos(lHwnd, HWND_NOTOPMOST, 0, 0, 0, 0, SWP_NOMOVE + SWP_NOSIZE)

End Sub

Public Sub SetTopLay(lHwnd As Long)
 
  Dim retVal As Long
  retVal = SetWindowPos(lHwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE + SWP_NOSIZE)
    
End Sub

Public Sub HideSystemMoveButton(hwnd As Long)
  RemoveMenu hwnd, SC_MOVE
End Sub

Public Sub HideSystemRestoreButton(hwnd As Long)
  RemoveMenu hwnd, SC_RESTORE
End Sub

Public Sub HideSystemCloseButton(hwnd As Long)
  RemoveMenu hwnd, SC_CLOSE
End Sub

Public Sub HideSystemMinButton(hwnd As Long)
  RemoveMenu hwnd, SC_MINIMIZE
End Sub

Public Sub HideSystemMaxButton(hwnd As Long)
  RemoveMenu hwnd, SC_MAXIMIZE
End Sub

Private Sub RemoveMenu(hwnd As Long, rButton As Long)
On Error Resume Next
    Dim hMenu As Long
    ' 给出系统菜单句柄.
    hMenu = GetSystemMenu(hwnd, False)
    Select Case rButton  '移去不同按钮
       Case SC_MOVE
        DeleteMenu hMenu, SC_MOVE, MF_BYPOSITION  '关闭
       Case SC_RESTORE
        DeleteMenu hMenu, SC_RESTORE, MF_BYPOSITION  '分条
       Case SC_MINIMIZE
        DeleteMenu hMenu, SC_MINIMIZE, MF_BYPOSITION  '最大化
       Case SC_MAXIMIZE
        DeleteMenu hMenu, SC_MAXIMIZE, MF_BYPOSITION  '最小化
       Case SC_CLOSE
        DeleteMenu hMenu, SC_CLOSE, MF_BYPOSITION  '大小
       Case SC_SIZE
        DeleteMenu hMenu, SC_SIZE, MF_BYPOSITION  '移动
       Case 0
        DeleteMenu hMenu, 0, MF_BYPOSITION  '恢复
    End Select
End Sub

Private Function GetMainKeyHandle(sMainKeyName As String) As Long
On Error Resume Next
 '系统注册表主键的常量列表
  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
    
'注册错误
On Error Resume Next
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)
   On Error Resume Next
   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  '如果大于0时将有目录
          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 CreateRegKey(sSubKey As String) As Boolean
On Error Resume Next