registry.bas

农村水电费记帐录入

Attribute VB_Name = "mdlRegistry"
Option Explicit
Global Const DbPassword = "option"
Global Const REG_SZ As Long = 1
Global Const REG_DWORD As Long = 4

Global Const HKEY_CLASSES_ROOT = &H80000000
Global Const HKEY_CURRENT_USER = &H80000001
Global Const HKEY_LOCAL_MACHINE = &H80000002
Global Const HKEY_USERS = &H80000003
Global gToday As Date '系统纪录的系统运作日期
Global Const ERROR_NONE = 0
Global Const ERROR_BADDB = 1
Global Const ERROR_BADKEY = 2
Global Const ERROR_CANTOPEN = 3
Global Const ERROR_CANTREAD = 4
Global Const ERROR_CANTWRITE = 5
Global Const ERROR_OUTOFMEMORY = 6
Global Const ERROR_INVALID_PARAMETER = 7
Global Const ERROR_ACCESS_DENIED = 8
Global Const ERROR_INVALID_PARAMETERS = 87
Global Const ERROR_NO_MORE_ITEMS = 259

Global Const KEY_ALL_ACCESS = &H3F

Global Const REG_OPTION_NON_VOLATILE = 0
Declare Function DiskID32 Lib "DiskID32.dll" (ByRef DiskModel As Byte, ByRef DiskID As Byte) As Long
Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Declare Function RegCreateKeyEx Lib "advapi32.dll" Alias "RegCreateKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal Reserved As Long, ByVal lpClass As String, ByVal dwOptions As Long, ByVal samDesired As Long, ByVal lpSecurityAttributes As Long, phkResult As Long, lpdwDisposition As Long) As Long
Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
Declare Function RegQueryValueExString Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, ByVal lpData As String, lpcbData As Long) As Long
Declare Function RegQueryValueExLong Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Long, lpcbData As Long) As Long
Declare Function RegQueryValueExNULL Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, ByVal lpData As Long, lpcbData As Long) As Long
Declare Function RegSetValueExString Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, ByVal lpValue As String, ByVal cbData As Long) As Long
Declare Function RegSetValueExLong Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpValue As Long, ByVal cbData As Long) As Long
Private Declare Function RegDeleteKey& Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String)
Private Declare Function RegDeleteValue& Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String)
Public gCnn As New ADODB.Connection
Global Guser As String 'login user
Global hostName As String 'hostname

Public Function DeleteKey(lPredefinedKey As Long, sKeyName As String)
    Dim lRetVal As Long         'result of the SetValueEx function
    Dim hKey As Long         'handle of open key
    
    lRetVal = RegDeleteKey(lPredefinedKey, sKeyName)

End Function

Public Function DeleteValue(lPredefinedKey As Long, sKeyName As String, sValueName As String)

       Dim lRetVal As Long         'result of the SetValueEx function
       Dim hKey As Long         'handle of open key

       'open the specified key

       lRetVal = RegOpenKeyEx(lPredefinedKey, sKeyName, 0, KEY_ALL_ACCESS, hKey)
       lRetVal = RegDeleteValue(hKey, sValueName)
       RegCloseKey (hKey)
End Function

Public Function SetValueEx(ByVal hKey As Long, sValueName As String, lType As Long, vValue As Variant) As Long
    Dim lValue As Long
    Dim sValue As String

    Select Case lType
        Case REG_SZ
            sValue = vValue
            SetValueEx = RegSetValueExString(hKey, sValueName, 0&, lType, sValue, Len(sValue))
        Case REG_DWORD
            lValue = vValue
            SetValueEx = RegSetValueExLong(hKey, sValueName, 0&, lType, lValue, 4)
        End Select

End Function
Function QueryValueEx(ByVal lhKey As Long, ByVal szValueName As String, vValue As Variant) As Long
    Dim cch As Long
    Dim lrc As Long
    Dim lType As Long
    Dim lValue As Long
    Dim sValue As String

    On Error GoTo QueryValueExError

    lrc = RegQueryValueExNULL(lhKey, szValueName, 0&, lType, 0&, cch)
    If lrc <> ERROR_NONE Then Error 5

    Select Case lType
        ' For strings
        Case REG_SZ:
            sValue = String(cch, 0)
            lrc = RegQueryValueExString(lhKey, szValueName, 0&, lType, sValue, cch)
            If lrc = ERROR_NONE Then
                vValue = left$(sValue, cch)
            Else
                vValue = Empty
            End If

        ' For DWORDS
        Case REG_DWORD:
            lrc = RegQueryValueExLong(lhKey, szValueName, 0&, lType, lValue, cch)
            If lrc = ERROR_NONE Then vValue = lValue
        Case Else
            'all other data types not supported
            lrc = -1
    End Select

QueryValueExExit:

    QueryValueEx = lrc
    Exit Function

QueryValueExError:

    Resume QueryValueExExit

End Function
Public Function CreateNewKey(lPredefinedKey As Long, sNewKeyName As String)
    Dim hNewKey As Long         'handle to the new key
    Dim lRetVal As Long         'result of the RegCreateKeyEx function
    
    lRetVal = RegCreateKeyEx(lPredefinedKey, sNewKeyName, 0&, vbNullString, REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, 0&, hNewKey, lRetVal)
    RegCloseKey (hNewKey)
End Function
Public Function SetKeyValue(lPredefinedKey As Long, sKeyName As String, sValueName As String, vValueSetting As Variant, lValueType As Long)
       Dim lRetVal As Long         'result of the SetValueEx function
       Dim hKey As Long         'handle of open key
       lRetVal = RegOpenKeyEx(lPredefinedKey, sKeyName, 0, KEY_ALL_ACCESS, hKey)
       lRetVal = SetValueEx(hKey, sValueName, lValueType, vValueSetting)
       RegCloseKey (hKey)

End Function

Public Function QueryValue(lPredefinedKey As Long, sKeyName As String, sValueName As String)
       Dim lRetVal As Long         'result of the API functions
       Dim hKey As Long         'handle of opened key
       Dim vValue As Variant      'setting of queried value


       lRetVal = RegOpenKeyEx(lPredefinedKey, sKeyName, 0, KEY_ALL_ACCESS, hKey)
       lRetVal = QueryValueEx(hKey, sValueName, vValue)
       'MsgBox vValue
       QueryValue = vValue
       RegCloseKey (hKey)
End Function

Public Function gGetMaxKey(strTableName As String) As Double
'求数据库中某个表的最大关键字的值
'返回值：表中存在纪录时返回相应的数值；不存在时返回0；出错时返回错误信息
'Author:zhangjunzhu
'Date:
'Description:得到单据号
'Parameter:入口参数TName为表名
'Sample:在流水—发票表中添加一条新记录，想获取新的单据号，则新单据号=gGetMaxID("流水_发票")
Dim RsTemp As New ADODB.Recordset
Dim Tid As Double
gCnn.Execute "update maxid set MaxID=MaxID+1 where tablename='" & strTableName & "'"
RsTemp.Open "select MaxID from MaxID where TableName='" & strTableName & "'", gCnn, adOpenKeyset

With RsTemp
    If .BOF And .EOF Then
      
        gCnn.Execute "insert into maxid(tablename,maxID) values('" & strTableName & "',1)"
        gGetMaxKey = 1
    Else
        gGetMaxKey = RsTemp!maxid
    End If
End With

End Function

Public Function PadCharL(ByVal strBuff, ByVal TotalLen, ByVal strChar) As String
'对长度小于totalen的串，再其左侧填相应数量的字符strchar，使其长度为totallen
'否则返回自右起，长度为totallen 的串
  Dim intLen As Integer, strTemp As String, intI As Integer
  
  intLen = LenOfC_zsx(strBuff)
  If intLen >= TotalLen Then
    PadCharL = Mid(strBuff, intLen - TotalLen + 1, TotalLen)
  Else
    strTemp = strBuff
    For intI = 1 To TotalLen - intLen
      strTemp = strChar & strTemp
    Next intI
    PadCharL = strTemp
  End If
End Function
Public Function LenOfC_zsx(ByVal strTemp As String)
'重新计算字符串长度，全角字符按长度为2进行计算
Dim intI As Integer, intEnd As Integer, lengths As Integer
   
  intEnd = Len(strTemp)
  lengths = intEnd
  For intI = 1 To intEnd
    If Asc(Mid(strTemp, intI, 1)) < 0 Then
       lengths = lengths + 1
    End If
  Next
  LenOfC_zsx = lengths
End Function
Public Sub DateEqualCheck()
Dim strprompt As String
strprompt = Chr(10) + Chr(11) + Chr(12) + Chr(13)
 MDIme.Sbar.Panels(2) = "现在北京时间:" & Format(Date, "yyyy/mm/dd")
'If gToday <> Date Then
'  MsgBox "系统在运行中检查到日期不一致, 日期可能在运行中被修改. 本系统纪录运作时间为:" & Format(gToday, "yyyy/mm/dd") & " 电脑当前时间:" & Format(Date, "yyyy/mm/dd") & ". 系统将自行终止运行", vbInformation
'
'  End
'End If

End Sub
Function ConvertMe(sConv0 As String) As String

'Author:zhangjunzhu
'Date:
'Description:小写金额转换成大写金额
'Parameter:入口参数sConv:要转换的金额，在使用该函数前，如果是数值型，请先转换成字符型
'Sample：ConvertMe("9.87")="玖元捌角柒分"

Dim sStr2, sConv, sConv1, sConv2, F As String