ROSTAM2
سه شنبه 05 اردیبهشت 1391, 00:59 صبح
این کد ها رو توی یک ماجول اضافه کن توابع api برای کار با رجیستریه
'************************************************* *****************************
' ProgID: Library.Registry
' Purpose: Wrapper for registry manipulation
' Author: John Powell (source freely available)
' Date: 04.12.2001
' Changes: none
'------------------------------------------------------------------------------
' Usage: CreateNewKey HKEY_CURRENT_USER, "TestKey\SubKey1\SubKey2"
' SetKeyValue HKEY_CURRENT_USER, "TestKey\SubKey1", "Test", "Testing, Testing", REG_SZ
' MsgBox QueryValue(HKEY_CURRENT_USER, "TestKey\SubKey1", "Test")
' DeleteKey HKEY_CURRENT_USER, "TestKey\SubKey1\SubKey2"
' DeleteValue HKEY_CURRENT_USER, "TestKey\SubKey1", "Test"
'************************************************* *****************************
Option Explicit
'************************************************* *****************************
' Class Variables
'************************************************* *****************************
'Value Type
Public Enum regValueType
REG_SZ = 1
REG_DWORD = 4
End Enum
'Predefined Keys
Public Enum regPredefinedKey
HKEY_CLASSES_ROOT = &H80000000
HKEY_CURRENT_USER = &H80000001
HKEY_LOCAL_MACHINE = &H80000002
HKEY_USERS = &H80000003
End Enum
'Errors
Public Enum regError
ERROR_NONE = 0
ERROR_BADDB = 1
ERROR_BADKEY = 2
ERROR_CANTOPEN = 3
ERROR_CANTREAD = 4
ERROR_CANTWRITE = 5
ERROR_OUTOFMEMORY = 6
ERROR_INVALID_PARAMETER = 7
ERROR_ACCESS_DENIED = 8
ERROR_INVALID_PARAMETERS = 87
ERROR_NO_MORE_ITEMS = 259
End Enum
Const KEY_ALL_ACCESS As Long = &H3F
Const REG_OPTION_NON_VOLATILE = 0
'API Declarations
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, ByVal lpSecurityAttributes As Long, phkResult As Long, lpdwDisposition As Long) 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 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
Private 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
Private 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
Private 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
Private 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)
'************************************************* *****************************
' Properties
'************************************************* *****************************
'************************************************* *****************************
' Public Methods
'************************************************* *****************************
'************************************************* *****************************
' Name: DeleteKey
' Inputs: Location As regPredefinedKey
' KeyName As String
' Returns: error code
' Usage: DeleteKey Location, KeyName
' Location must be HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_lOCAL_MACHINE
' KeyName is name of the key you wish to delete, it may include subkeys (example "Key1\SubKey1")
' Example: DeleteKey HKEY_CURRENT_USER, "TestKey\SubKey1\SubKey2"
'------------------------------------------------------------------------------
' Purpose: Deletes a key
' Author: John Powell
' Date: 04.12.2001
' Changes: none
'************************************************* *****************************
Public Function DeleteKey(Location As regPredefinedKey, KeyName As String) As regError
DeleteKey = RegDeleteKey(Location, KeyName)
End Function
'************************************************* *****************************
' Name: DeleteValue
' Inputs: Location As regPredefinedKey
' KeyName As String
' ValueName As String
' Returns: error code
' Usage: DeleteValue Location, KeyName, ValueName
' Location must equal HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_lOCAL_MACHINE
' KeyName is name of the key that holds the value to delete, it may include subkeys (example "Key1\SubKey1")
' ValueName is the name of value you wish to delete
' Example: DeleteValue HKEY_CURRENT_USER, "TestKey\SubKey1", "Test"
'------------------------------------------------------------------------------
' Purpose: Deletes a value
' Author: John Powell
' Date: 04.12.2001
' Changes: none
'************************************************* *****************************
Public Function DeleteValue(Location As regPredefinedKey, KeyName As String, ValueName As String) As regError
Dim lRetVal As Long 'Result of the SetValueEx function
Dim hKey As Long 'Handle of open key
'Attempt to open the key
lRetVal = RegOpenKeyEx(Location, KeyName, 0, KEY_ALL_ACCESS, hKey)
'If the key was opened, delete the value
If lRetVal = ERROR_NONE Then
'Delete the value
lRetVal = RegDeleteValue(hKey, ValueName)
'Close the key
RegCloseKey (hKey)
End If
'Return the result
DeleteValue = lRetVal
End Function
'************************************************* *****************************
' Name: CreateNewKey
' Inputs: Location As regPredefinedKey
' KeyName As String
' Returns: error code
' Usage: CreateNewKey Location, NewKeyName
' Location must equal HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_lOCAL_MACHINE
' KeyName is name of the key that holds the value to delete, it may include subkeys (example "Key1\SubKey1")
' Example: CreateNewKey HKEY_CURRENT_USER, "TestKey\SubKey1\SubKey2"
'------------------------------------------------------------------------------
' Purpose: Creates a new key
' Author: John Powell
' Date: 04.12.2001
' Changes: none
'************************************************* *****************************
Public Function CreateNewKey(Location As regPredefinedKey, NewKeyName As String) As regError
Dim hNewKey As Long 'Handle to the new key
Dim lRetVal As Long 'Result of the RegCreateKeyEx function
lRetVal = RegCreateKeyEx(Location, NewKeyName, 0&, vbNullString, REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, 0&, hNewKey, lRetVal)
If lRetVal = ERROR_NONE Then
RegCloseKey (hNewKey)
End If
'Return the result
CreateNewKey = lRetVal
End Function
'************************************************* *****************************
' Name: SetKeyValue
' Inputs: Location As Long
' KeyName As String
' ValueName as String
' ValueSetting As Variant
' ValueType As regValueType
' Returns: error code
' Usage: SetKeyValue Location, KeyName, ValueName, ValueSetting, ValueType
' Location must equal HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_lOCAL_MACHINE
' KeyName is name of the key that holds the value to delete, it may include subkeys (example "Key1\SubKey1")
' ValueName is the name of the value you want create, or set the value of (example: "ValueTest")
' ValueSetting is what you want the value set to
' ValueType must equal either REG_SZ (a string) Or REG_DWORD (an integer)
' Example: SetKeyValue HKEY_CURRENT_USER, "TestKey\SubKey1", "Test", "Testing, Testing", REG_SZ
'------------------------------------------------------------------------------
' Purpose: Sets the data field of a value
' Author: John Powell
' Date: 04.12.2001
' Changes: none
'************************************************* *****************************
Public Function SetKeyValue(Location As regPredefinedKey, KeyName As String, ValueName As String, ValueSetting As Variant, ValueType As regValueType) As regError
Dim lRetVal As Long 'Result of the SetValueEx function
Dim hKey As Long 'Handle of open key
lRetVal = RegOpenKeyEx(Location, KeyName, 0, KEY_ALL_ACCESS, hKey)
'If the key was opened, set the value
If lRetVal = ERROR_NONE Then
lRetVal = SetValueEx(hKey, ValueName, ValueType, ValueSetting)
'Close the key
RegCloseKey (hKey)
End If
'Return the result
SetKeyValue = lRetVal
End Function
'************************************************* *****************************
' Name: QueryValue
' Inputs: Location As Long
' KeyName As String
' ValueName as String
' Returns: Empty string if error | value at 'Location\KeyName\ValueName'
' Usage: QueryValue Location, KeyName, ValueName
' Location must equal HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_lOCAL_MACHINE
' KeyName is the key that the value is under (example: "Software\Microsoft\Windows\CurrentVersion\Explorer")
' ValueName is the name of the value you want to access (example: "link")' Example: Msgbox QueryValue(HKEY_CURRENT_USER, "TestKey\SubKey1", "Test")
'------------------------------------------------------------------------------
' Purpose: Sets the data field of a value
' Author: John Powell
' Date: 04.12.2001
' Changes: none
'************************************************* *****************************
Public Function QueryValue(Location As regPredefinedKey, KeyName As String, ValueName As String) 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
'Open the key
lRetVal = RegOpenKeyEx(Location, KeyName, 0, KEY_ALL_ACCESS, hKey)
'Query the value
lRetVal = QueryValueEx(hKey, ValueName, vValue)
'Return the value
QueryValue = cleanProperty(vValue)
'Close the key
RegCloseKey (hKey)
End Function
'************************************************* *****************************
' Name: LightWeightEncrypt
' Inputs: Text As String
' EncryptKey As Integer
' Returns: Encrypted or decrypted string
' Usage: Encode: SecretPassword = LightWeightEncrypt(SecretPassword, 80)
' DeCode: SecretPassword = LightWeightEncrypt(SecretPassword, 80)
'------------------------------------------------------------------------------
' Purpose: Lightweight encryption of a string key
' Useful for hiding values in the registry
' Author: John Powell
' Date: 04.12.2001
' Changes: none
'************************************************* *****************************
Public Function LightWeightEncrypt(Text As String, EncryptKey As Integer) As String
Dim Temp As String, RR As Integer
For RR = 1 To Len(Text)
Temp$ = Temp$ + Chr$(Asc(Mid(Text, RR, 1)) Xor EncryptKey)
Next RR
LightWeightEncrypt = Temp
End Function
'************************************************* *****************************
' Private Methods
'************************************************* *****************************
'************************************************* *****************************
' Name: SetValueEx
' Inputs: ByVal hKey As Long
' ValueName As String
' lType As Long
' vValue As Variant
' Returns: none
'------------------------------------------------------------------------------
' Purpose: Set a value
' Author: John Powell
' Date: 04.12.2001
' Changes: none
'************************************************* *****************************
Private Function SetValueEx(ByVal hKey As Long, ValueName 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, ValueName, 0&, lType, sValue, Len(sValue))
Case REG_DWORD
lValue = vValue
SetValueEx = RegSetValueExLong(hKey, ValueName, 0&, lType, lValue, 4)
End Select
End Function
'************************************************* *****************************
' Name: QueryValueEx
' Inputs: lhKey As Long
' szValueName
' vValue As Variant
' hKey As Long
' Returns: none
'------------------------------------------------------------------------------
' Purpose: Get a value
' Author: John Powell
' Date: 04.12.2001
' Changes: none
'************************************************* *****************************
Private 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
' Determine the size and type of data to be read
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
'************************************************* *****************************
' Name: cleanProperty
' Inputs: Property As String
' Returns: A "cleaned" string
'------------------------------------------------------------------------------
' Purpose: Chop of the last character because there is an end of string
' character present when getting a string from the registry
' Author: John Powell
' Date: 04.12.2001
' Changes: none
'************************************************* *****************************
Private Function cleanProperty(ByVal Property As String) As String
cleanProperty = Left(Property, (Len(Property) - 1))
End Function
vBulletin® v4.2.5, Copyright ©2000-1404, Jelsoft Enterprises Ltd.