codice:
Option Explicit
Global Const HKEY_CLASSES_ROOT = &H80000000
Global Const HKEY_CURRENT_USER = &H80000001
Global Const HKEY_LOCAL_MACHINE = &H80000002
Global Const HKEY_USERS = &H80000003
Private Const ERROR_SUCCESS = 0&
Private Const ERROR_NO_MORE_ITEMS = 259&
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
Private Const REG_OPTION_NON_VOLATILE = 0
Private Const KEY_QUERY_VALUE = &H1
Private Const KEY_SET_VALUE = &H2
Private Const KEY_CREATE_SUB_KEY = &H4
Private Const KEY_ENUMERATE_SUB_KEYS = &H8
Private Const KEY_NOTIFY = &H10
Private Const KEY_CREATE_LINK = &H20
Private Const SYNCHRONIZE = &H100000
Private Const STANDARD_RIGHTS_ALL = &H1F0000
Private Const KEY_ALL_ACCESS = ((STANDARD_RIGHTS_ALL Or KEY_QUERY_VALUE Or _
KEY_SET_VALUE Or KEY_CREATE_SUB_KEY Or KEY_ENUMERATE_SUB_KEYS Or _
KEY_NOTIFY Or KEY_CREATE_LINK) And (Not SYNCHRONIZE))
Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Boolean
End Type
Declare Function RegCreateKey Lib "advapi32" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpszSubKey As String, phkResult 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, lpSecurityAttributes As Any, phkResult As Long, lpdwDisposition As Long) As Long
Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String) As Long
Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String) As Long
Declare Function RegCloseKey Lib "advapi32.dll" _
(ByVal hKey As Long) _
As Long
Declare Function RegEnumKeyEx Lib "advapi32" Alias "RegEnumKeyA" _
(ByVal hKey As Long, _
ByVal iSubKey As Long, _
ByVal lpszName As String, _
ByVal cchName As Long) _
As Long
Declare Function RegOpenKeyEx Lib "advapi32" Alias "RegOpenKeyExA" _
(ByVal hKey As Long, _
ByVal lpszSubKey As String, _
ByVal ulOptions As Long, _
ByVal samDesired As Long, _
phkResult As Long) _
As Long
Declare Function RegQueryValueEx Lib "advapi32" Alias "RegQueryValueExA" _
(ByVal hKey As Long, _
ByVal lpszValueName As String, _
ByVal dwReserved As Long, _
lpdwType As Long, _
lpbData As Any, _
cbData As Long) _
As Long
Declare Function RegSetValueEx Lib "advapi32" Alias "RegSetValueExA" _
(ByVal hKey As Long, _
ByVal lpszValueName As String, _
ByVal dwReserved As Long, _
ByVal fdwType As Long, _
lpbData As Any, _
ByVal cbData As Long) _
As Long
Declare Function RegSetStringEx Lib "advapi32" Alias "RegSetValueExA" _
(ByVal hKey As Long, _
ByVal lpszValueName As String, _
ByVal dwReserved As Long, _
ByVal fdwType As Long, _
lpbData As String, _
ByVal cbData As Long) _
As Long
Declare Function GetCurrentProcessId Lib "kernel32" () As Long
Function CreateRegEntry(PrimaryKey As Long, Key As String, KeyToAdd As Variant, pDatatype As Long, ValueToAdd As Variant) As Boolean
On Local Error GoTo CreateRegEntry_Err
Dim lResult As Long, i As Integer, msg As String
Dim strMyKeyFull As String, MyKeyName As String
Dim MyKeyValueLng As Long, MyKeyValueStr As String
Dim MyDataType As Long, phkResult As Long, IsNewKey As Long
lResult = RegCreateKeyEx(PrimaryKey, Key, 0&, _
REG_SZ, REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, _
ByVal 0&, phkResult, IsNewKey)
If Not (lResult = ERROR_SUCCESS) Then
CreateRegEntry = False
msg = "Error Creating Registry Key Entry:" & vbCrLf
msg = msg & "Key=" & strMyKeyFull & vbCrLf
msg = msg & "DLL Returned=" & Format$(lResult)
MsgBox msg, vbOKOnly Or vbExclamation, App.Title
GoTo CreateRegEntry_End
End If
Select Case pDatatype
Case REG_DWORD
MyKeyValueLng = ValueToAdd
lResult = RegSetValueEx(phkResult, KeyToAdd, ByVal 0&, pDatatype, MyKeyValueLng, Len(MyKeyValueLng))
Case REG_SZ
MyKeyValueStr = ValueToAdd
lResult = RegSetValueEx(phkResult, KeyToAdd, ByVal 0&, pDatatype, ByVal MyKeyValueStr, Len(MyKeyValueStr))
End Select
If Not (lResult = ERROR_SUCCESS) Then
CreateRegEntry = False
msg = "Error Creating Registry Key Entry:" & vbCrLf
msg = msg & "Key=" & KeyToAdd & vbCrLf
msg = msg & "DLL Returned=" & Format$(lResult)
MsgBox msg, vbOKOnly Or vbExclamation, App.Title
GoTo CreateRegEntry_End
End If
CreateRegEntry = True
CreateRegEntry_End:
Exit Function
CreateRegEntry_Err:
MsgBox Error.Description, vbOKOnly Or vbExclamation, App.Title
Resume CreateRegEntry_End
End Function
Function DeleteAllAppRegEntries() As Boolean
On Local Error GoTo DeleteAllAppRegEntries_Err
Dim lResult As Long, msg As String
Dim hKey As Long
lResult = RegOpenKeyEx(HKEY_LOCAL_MACHINE, _
REG_APP_KEYS_PATH, _
ByVal 0&, KEY_ALL_ACCESS, hKey)
If Not (lResult = ERROR_SUCCESS) Then
DeleteAllAppRegEntries = False
msg = "Error Opening Registry Key Entry:" & vbCrLf
msg = msg & "Key/Path=" & REG_APP_KEYS_PATH & vbCrLf
msg = msg & "DLL Returned=" & Format$(lResult)
MsgBox msg, vbOKOnly Or vbExclamation, App.Title
GoTo DeleteAllAppRegEntries_End
End If
lResult = RegDeleteKey(hKey, "")
If Not (lResult = ERROR_SUCCESS) Then
DeleteAllAppRegEntries = False
msg = "Error Deleting Registry Key Entry:" & vbCrLf
msg = msg & "Key=" & REG_APP_KEYS_PATH & vbCrLf
msg = msg & "DLL Returned=" & Format$(lResult)
MsgBox msg, vbOKOnly Or vbExclamation, App.Title
GoTo DeleteAllAppRegEntries_End
End If
lResult = RegCloseKey(hKey)
DeleteAllAppRegEntries = True
DeleteAllAppRegEntries_End: Exit Function
DeleteAllAppRegEntries_Err:
MsgBox Error.Description, vbOKOnly Or vbExclamation, App.Title
Resume DeleteAllAppRegEntries_End
End Function
Function GetAppRegValue(SubKey As String, WhatKey As String, KeyDataType As Variant, KeyValue As Variant, IsVerbose As Integer) As Boolean
On Local Error GoTo GetAppRegValue_Err
Dim lResult As Long, dwResult As Long
Dim dwType As Long, cbData As Long
Dim varStrData As String, varLngData As Long
Dim msg As String
lResult = RegOpenKeyEx(HKEY_LOCAL_MACHINE, _
REG_APP_KEYS_PATH + "\" + SubKey, _
ByVal 0&, KEY_ALL_ACCESS, dwResult)
If Not (lResult = ERROR_SUCCESS) Then
GetAppRegValue = False
If IsVerbose Then
msg = "Error Opening Registry Key Entry:" & vbCrLf
msg = msg & "Key/Path=" & REG_APP_KEYS_PATH & vbCrLf
msg = msg & "DLL Returned=" & Format$(lResult)
MsgBox msg, vbOKOnly Or vbExclamation, App.Title
End If
GoTo GetAppRegValue_End
End If
' ***********************************************
' Set up passed variables and retrieve value.
' ***********************************************
Select Case KeyDataType
Case REG_SZ
varStrData = String$(255, 0)
cbData = Len(varStrData)
lResult = RegQueryValueEx(dwResult, WhatKey, ByVal 0&, _
dwType, ByVal varStrData, cbData)
Case REG_DWORD
varLngData = False
cbData = Len(varLngData)
lResult = RegQueryValueEx(dwResult, WhatKey, ByVal 0&, _
dwType, varLngData, cbData)
End Select
If Not (lResult = ERROR_SUCCESS) Then
GetAppRegValue = False
If IsVerbose Then
msg = "Error Retrieving Registry Key Entry:" & vbCrLf
msg = msg & "Key=" & WhatKey & vbCrLf
msg = msg & "DLL Returned=" & Format$(lResult)
MsgBox msg, vbOKOnly Or vbExclamation, App.Title
End If
lResult = RegCloseKey(dwResult)
GoTo GetAppRegValue_End
End If
' *********************************************** ' Close key.
' ***********************************************
lResult = RegCloseKey(dwResult)
' ***********************************************
' Select data type (for the needed types
' used in the values) and assign value.
' ***********************************************
Select Case dwType
Case REG_NONE
KeyValue = vbNull
Case REG_SZ
KeyValue = Left$(varStrData, cbData)
If cbData > 0 Then
If (Asc(Mid(KeyValue, cbData, 1)) = 0) Then ' Win95 Adds Null Terminated String...
KeyValue = Left(KeyValue, cbData - 1) ' Null Found, Extract From String
End If ' WinNT Does NOT Null Terminate String...
End If
Case REG_DWORD
KeyValue = varLngData
Case Else
KeyValue = vbNull
End Select
GetAppRegValue = True
Debug.Print KeyValue
GetAppRegValue_End:
Exit Function
GetAppRegValue_Err:
MsgBox Error.Description, vbExclamation, App.Title
Resume GetAppRegValue_End
End Function
Function SetAppRegValue(SubKey As String, WhatKey As String, KeyDataType As Variant, NewKeyValue As Variant) As Boolean
On Local Error GoTo SetAppRegValue_Err
' ***********************************************
' Declare local usage variables.
' ***********************************************
Dim lResult As Long, dwResult As Long
Dim dwType As Long, cbData As Long
Dim varStrData As String, varLngData As Long
Dim msg As String
' ***********************************************
' Open the key for application's path.
' ***********************************************
lResult = RegOpenKeyEx(HKEY_LOCAL_MACHINE, _
REG_APP_KEYS_PATH + "\" + SubKey, _
ByVal 0&, KEY_ALL_ACCESS, dwResult)
If Not (lResult = ERROR_SUCCESS) Then
SetAppRegValue = False
msg = "Error Opening Registry Key Entry:" & vbCrLf
msg = msg & "Key/Path=" & REG_APP_KEYS_PATH & vbCrLf
msg = msg & "DLL Returned=" & Format$(lResult)
MsgBox msg, vbOKOnly Or vbExclamation, App.Title
GoTo SetAppRegValue_End
End If
' ***********************************************
' Set up passed variables and retrieve value.
' ***********************************************
Select Case KeyDataType
Case REG_SZ
varStrData = NewKeyValue
lResult = RegSetValueEx(dwResult, WhatKey, _
ByVal 0&, KeyDataType, _
ByVal varStrData, Len(varStrData))
Case REG_DWORD
varLngData = CLng(NewKeyValue)
lResult = RegSetValueEx(dwResult, WhatKey, _
ByVal 0&, KeyDataType, _
varLngData, Len(varLngData))
End Select
If Not (lResult = ERROR_SUCCESS) Then
SetAppRegValue = False
msg = "Error Setting Registry Key Entry:" & vbCrLf
msg = msg & "Key=" & WhatKey & vbCrLf
msg = msg & "DLL Returned=" & Format$(lResult)
MsgBox msg, vbOKOnly Or vbExclamation, App.Title
lResult = RegCloseKey(dwResult)
GoTo SetAppRegValue_End
End If
' *********************************************** ' Close key.
' ***********************************************
lResult = RegCloseKey(dwResult)
SetAppRegValue = True
SetAppRegValue_End:
Exit Function
SetAppRegValue_Err:
MsgBox Error.Description, vbOKOnly Or vbExclamation, App.Title
Resume SetAppRegValue_End
End Function
Rispondi quotando