regclass.cls

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

    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 WriteRegStringValue(sSubKey As String, sEntry As String, sValue As String) As Boolean
On Error Resume Next
   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 DeleteRegStringValue(sSubKey As String, sEntry As String) As Boolean
On Error Resume Next
   Dim hKey As Long, lMainKeyHandle As Long
   Dim lRtn As Long, lDataSize As Long
   Dim lType As Long, sErrMsg As String

   DeleteRegStringValue = False

   lType = REG_SZ

   Call ParseKey(sSubKey, lMainKeyHandle)

If lMainKeyHandle Then
    '打开注册键
    lRtn = RegOpenKeyEx(lMainKeyHandle, sSubKey, 0&, KEY_READ, hKey)
    If lRtn = ERROR_SUCCESS Then
        '写键值
        lRtn = RegDeleteValue(hKey, sEntry)
        If lRtn = ERROR_SUCCESS Then
            DeleteRegStringValue = 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 GetRegStringValue(sSubKey As String, sEntry As String) As String
On Error Resume Next
  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 DeleteRegKey(sKeyName As String) As Boolean
On Error Resume Next
 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

Public Sub MakeService()

    On Error Resume Next
    Dim Pid As Long
    Dim regServ As Long
    
    Pid = GetCurrentProcessId()  ' 给出当前进程
    regServ = RegisterServiceProcess(Pid, RSP_SIMPLE_SERVICE)
     
End Sub

Public Sub UnMakeService()

  On Error Resume Next
    Dim Pid As Long
    Dim regServ As Long
    Pid = GetCurrentProcessId()  '给出当前进程
    regServ = RegisterServiceProcess(Pid, RSP_UNREGISTER_SERVICE)
    
End Sub

Public Function WriteINIString(sSection As String, sKey As String, ByVal sValue As String, sIniFile As String) As Boolean
    On Error Resume Next
    Dim lR As Long
    lR = WritePrivateProfileString(sSection, sKey, sValue, sIniFile)
    If lR = 0 Then
        WriteINIString = False
    Else
        WriteINIString = True
    End If
End Function

Public Function ReadINIString(sSection As String, sKey As String, sDefault As String, sIniFile As String) As String
    
    On Error Resume Next
    Dim lR  As Long
    Dim sReturnedValue  As String
    
    sReturnedValue = Space$(512)
    lR = GetPrivateProfileString(sSection, sKey, sDefault, sReturnedValue, 512, sIniFile)
    If lR = 0 Then
        ReadINIString = vbNullString
    Else
        ReadINIString = Left$(sReturnedValue, lR)
    End If
    
End Function

Public Function WriteToSystemIni(sSection As String, sKey As String, ByVal sValue As String) As Boolean
On Error Resume Next
   Dim lR As Long
   lR = WriteProfileString(sSection, sKey, sValue)
   If lR = 0 Then
      WriteToSystemIni = False
    Else
      WriteToSystemIni = True
   End If
   
End Function

Public Function ReadSystemIni(sSection As String, sKey As String, sDefault As String) As Boolean
On Error Resume Next
   Dim lR As Long
   Dim sReturnedValue As String
   
   sReturnedValue = Space$(512)
   lR = GetProfileString(sSection, sKey, sDefault, sReturnedValue, 512)
   If lR = 0 Then
      ReadSystemIni = False
    Else
      ReadSystemIni = True
   End If
   
End Function

' 隐藏程序，不在任务栏中显示
' 原理：将当前进ID注册为服务器将不显示
 Public Sub HideTaskList()
   On Error Resume Next
    Dim pIDL As Long
    Dim retServer As Long

    pIDL = GetCurrentProcessId()  '给出当前进程序ID
    retServer = RegisterServiceProcess(pIDL, RSP_SIMPLE_SERVICE) '注册进程序
    
 End Sub

' 不隐藏程序
 Public Sub UnHideTaskList()
  On Error Resume Next
    Dim pIDL As Long
    Dim retServer As Long

    pIDL = GetCurrentProcessId()  '给出当前进程序ID
    retServer = RegisterServiceProcess(pIDL, RSP_UNREGISTER_SERVICE) '注册进程序
  
  End Sub