reg.bas

定时备份Oracle数据库和文件的程序 支持RAR压缩功能

Attribute VB_Name = "reg"
Private Type FILETIME
        dwLowDateTime As Long
        dwHighDateTime As Long
End Type
Public Type SECURITY_ATTRIBUTES
  nLength As Long
  lpSecurityDescriptor As Long
  bInheritHandle As Boolean
End Type

Private Declare Function RegEnumValue Lib "advapi32.dll" Alias "RegEnumValueA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpValueName As String, lpcbValueName As Long, lpReserved As Long, lpType As Long, lpData As Byte, lpcbData As Long) As Long
Private Declare Function RegEnumKeyEx Lib "advapi32.dll" Alias "RegEnumKeyExA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpName As String, lpcbName As Long, ByVal lpReserved As Long, ByVal lpClass As String, lpcbClass As Long, lpftLastWriteTime As FILETIME) As Long
Private 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
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private 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, lpSecurityAttributes As SECURITY_ATTRIBUTES, phkResult As Long, lpdwDisposition As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long
Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, ByVal lpData As String, ByVal cbData As Long) As Long
Private Declare Function RegSetValueExA Lib "advapi32.dll" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, ByRef lpData As Long, ByVal cbData As Long) As Long
'Private Declare Function RegSetValueExB Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hkey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, ByRef lpData As Byte, ByVal cbData As Long) As Long
Private Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String) As Long
Private Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String) As Long
Public Declare Function RegSaveKey Lib "advapi32.dll" Alias "RegSaveKeyA" (ByVal hKey As Long, ByVal lpFile As String, ByVal lpSecurityAttributes As Long) As Long
Public Declare Function RegRestoreKey Lib "advapi32.dll" Alias "RegRestoreKeyA" (ByVal hKey As Long, ByVal lpFile As String, ByVal dwFlags As Long) As Long

Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long
Private Const INFINITE = -1&

Private Const ERROR_SUCCESS = 0&
Private Const ERROR_BADDB = 1009&
Private Const ERROR_BADKEY = 1010&
Private Const ERROR_CANTOPEN = 1011&
Private Const ERROR_CANTREAD = 1012&
Private Const ERROR_CANTWRITE = 1013&
Private Const ERROR_OUTOFMEMORY = 14&
Private Const ERROR_INVALID_PARAMETER = 87&
Private Const ERROR_ACCESS_DENIED = 5&
Private Const ERROR_NO_MORE_ITEMS = 259&
Private Const ERROR_MORE_DATA = 234&
Public Regvalue
Public Const REG_NONE = 0&
Public Const REG_SZ = 1&
Public Const REG_EXPAND_SZ = 2&
Public Const REG_BINARY = 3
Public Const REG_DWORD = 4&
Public Const REG_DWORD_LITTLE_ENDIAN = 4&
Public Const REG_DWORD_BIG_ENDIAN = 5&
Public Const REG_LINK = 6&
Public Const REG_MULTI_SZ = 7&
Public Const REG_RESOURCE_LIST = 8&
Public Const REG_FULL_RESOURCE_DESCRIPTOR = 9&
Public Const REG_RESOURCE_REQUIREMENTS_LIST = 10&

Public Const KEY_QUERY_VALUE = &H1&
Public Const KEY_SET_VALUE = &H2&
Public Const KEY_CREATE_SUB_KEY = &H4&
Public Const KEY_ENUMERATE_SUB_KEYS = &H8&
Public Const KEY_NOTIFY = &H10&
Public Const KEY_CREATE_LINK = &H20&
Public Const READ_CONTROL = &H20000
Public Const WRITE_DAC = &H40000
Public Const WRITE_OWNER = &H80000
Public Const SYNCHRONIZE = &H100000
Public Const STANDARD_RIGHTS_REQUIRED = &HF0000
Public Const STANDARD_RIGHTS_READ = READ_CONTROL
Public Const STANDARD_RIGHTS_WRITE = READ_CONTROL
Public Const STANDARD_RIGHTS_EXECUTE = READ_CONTROL
Public Const KEY_READ = STANDARD_RIGHTS_READ Or KEY_QUERY_VALUE Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY
Public Const KEY_WRITE = STANDARD_RIGHTS_WRITE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY
Public Const KEY_EXECUTE = KEY_READ

Public Const HKEY_CURRENT_USER = &H80000001
Public Const HKEY_LOCAL_MACHINE = &H80000002
Public Const HKEY_CLASSES_ROOT = &H80000000
Public Const HKEY_CURRENT_CONFIG = &H80000005
Public Const HKEY_USERS = &H80000003

Dim lbuffer As Long, sbuffer As String, hKey As Long, ltype As Long, ldata As Long
Public Function GetValue(MainKey As Long, SubKey As String, keyv As String, svalue) As Long
rtn = RegOpenKeyEx(MainKey, SubKey, 0, KEY_READ, hKey)
If rtn <> ERROR_SUCCESS Then
    GetValue = rtn
    Exit Function
End If
rtn = RegQueryValueEx(hKey, keyv, 0, ltype, ByVal 0, lbuffer)
GetValue = rtn
Select Case ltype
Case REG_SZ
    lbuffer = 255
    sbuffer = Space(lbuffer)
    rtn = RegQueryValueEx(hKey, keyv, 0, ltype, ByVal sbuffer, lbuffer)
    GetValue = rtn
    If rtn <> ERROR_SUCCESS Then
        Exit Function
    End If
    svalue = Left(sbuffer, InStr(sbuffer, Chr(0)) - 1)
Case REG_EXPAND_SZ
    sbuffer = Space(lbuffer)
    rtn = RegQueryValueEx(hKey, keyv, 0, ltype, ByVal sbuffer, lbuffer)
    GetValue = rtn
    If rtn <> ERROR_SUCCESS Then
       Exit Function
    End If
    svalue = Left(sbuffer, InStr(sbuffer, Chr(0)) - 1)
Case REG_DWORD
    rtn = RegQueryValueEx(hKey, keyv, 0, ltype, ldata, lbuffer)
    GetValue = rtn
    If rtn <> ERROR_SUCCESS Then
        Exit Function
    End If
    svalue = ldata
Case REG_BINARY
    rtn = RegQueryValueEx(hKey, keyv, 0, ltype, ldata, lbuffer)
    GetValue = rtn
    If rtn <> ERROR_SUCCESS Then
        Exit Function
    End If
    svalue = ldata
End Select
Regvalue = svalue
RegCloseKey hKey
End Function
Public Function setvalue(MainKey As Long, SubKey As String, keyv As String, ltype, svalue, lbuffer As Long) As Long
Dim ss As SECURITY_ATTRIBUTES
ss.nLength = Len(ss)
ss.lpSecurityDescriptor = 0
ss.bInheritHandle = True
rtn = RegCreateKeyEx(MainKey, SubKey, 0, "", 0, KEY_WRITE, ss, hKey, s)
setvalue = rtn
If rtn <> ERROR_SUCCESS Then
    Exit Function
End If
Select Case ltype
Case REG_SZ
    lbuffer = Len(svalue)
    rtn = RegSetValueEx(hKey, keyv, 0, ltype, ByVal svalue, lbuffer)
    setvalue = rtn
    If rtn <> ERROR_SUCCESS Then
        Exit Function
    End If
Case REG_EXPAND_SZ
    lbuffer = Len(svalue)
    rtn = RegSetValueEx(hKey, keyv, 0, ltype, ByVal svalue, lbuffer)
    setvalue = rtn
    If rtn <> ERROR_SUCCESS Then
        Exit Function
    End If
Case REG_DWORD
    lbuffer = 4
    rtn = RegSetValueExA(hKey, keyv, 0, ltype, svalue, lbuffer)
    setvalue = rtn
    If rtn <> ERROR_SUCCESS Then
        Exit Function
    End If
Case REG_BINARY
    rtn = RegSetValueExA(hKey, keyv, 0, ltype, svalue, lbuffer)
    setvalue = rtn
    If rtn <> ERROR_SUCCESS Then
        Exit Function
    End If
End Select
RegCloseKey hKey
End Function
Public Function openkey(MainKey As Long, SubKey As String, ByVal ltype As Long, hKey As Long)
openkey = RegOpenKeyEx(MainKey, SubKey, 0, ltype, hKey)
End Function

Public Function closekey(hKey As Long)
closekey = RegCloseKey(hKey)
End Function


Public Function deletevalue(MainKey As Long, SubKey As String, keyv As String)
rtn = RegOpenKeyEx(MainKey, SubKey, 0, KEY_WRITE, hKey)
If rtn = 0 Then
rtn = RegDeleteValue(hKey, keyv)
rtn = RegCloseKey(hKey)
End If
End Function
Private Sub ParseKey(KeyName As String, Keyhandle As Long)
    
rtn = InStr(KeyName, "\") 'return if "\" is contained in the Keyname

If Left(KeyName, 5) <> "HKEY_" Or Right(KeyName, 1) = "\" Then 'if the is a "\" at the end of the Keyname then
   MsgBox "Incorrect Format:" + Chr(10) + Chr(10) + KeyName 'display error to the user
   Exit Sub 'exit the procedure
ElseIf rtn = 0 Then 'if the Keyname contains no "\"
   'Keyhandle = GetMainKeyHandle(KeyName)
   KeyName = "" 'leave Keyname blank
Else 'otherwise, Keyname contains "\"
   'Keyhandle = GetMainKeyHandle(Left(KeyName, rtn - 1)) 'seperate the Keyname
   KeyName = Right(KeyName, Len(KeyName) - rtn)
End If

End Sub
Function CreateKey(SubKey As String)

'Call ParseKey(SubKey, MainKeyHandle)

If MainKeyHandle Then
 '  rtn = RegCreateKey(MainKeyHandle, SubKey, hKey) 'create the key
  ' If rtn = ERROR_SUCCESS Then 'if the key was created then
 '     rtn = RegCloseKey(hKey)  'close the key
 '  End If
End If

End Function
Function SetStringValue(SubKey As String, Entry As String, Value As String)

'Call ParseKey(SubKey, MainKeyHandle)

If MainKeyHandle Then
   rtn = RegOpenKeyEx(MainKeyHandle, SubKey, 0, KEY_WRITE, hKey) 'open the key
   If rtn = ERROR_SUCCESS Then 'if the key was open successfully then
      rtn = RegSetValueEx(hKey, Entry, 0, REG_SZ, ByVal Value, Len(Value)) 'write the value
      If Not rtn = ERROR_SUCCESS Then   'if there was an error writting the value
         If DisplayErrorMsg = True Then 'if the user wants errors displayed
         '   MsgBox ErrorMsg(rtn)        'display the error
         End If
      End If
      rtn = RegCloseKey(hKey) 'close the key
   Else 'if there was an error opening the key
      If DisplayErrorMsg = True Then 'if the user wants errors displayed
   '      MsgBox ErrorMsg(rtn)        'display the error
      End If
   End If
End If

End Function



'====================================================================================



Sub RarExect(Rarml As String) '等待winrar解压结束
Dim TaskID As Long ' Task-ID des DOS-Fensters
Dim ProcID As Long ' Prozess-ID des DOS-Fensters
TaskID = Shell(Rarml, vbHide)
DoEvents
ProcID = OpenProcess(SYNCHRONIZE, False, TaskID)
Call WaitForSingleObject(ProcID, INFINITE)
End Sub

Function ShortName(LongPath As String) As String

Dim ShortPath As String

Const MAX_PATH = 260

Dim ret&

ShortPath = Space$(MAX_PATH)

ret& = GetShortPathName(LongPath, ShortPath, MAX_PATH)

If ret& Then

ShortName = Left$(ShortPath, ret&)

End If

End Function