Option Explicit
Private Const REG_SZ = 1 'tipo stringa
Private Const REG_BINARY = 3 'tipo valore binario
Private Const REG_DWORD = 4 'tipo DWORD
Private Const ERROR_SUCCESS = 0&
Private Const ERROR_NO_MORE_ITEMS = 259&
Private Const STANDARD_RIGHTS_ALL = &H1F0000
Private Const SYNCHRONIZE = &H100000
Private Const READ_CONTROL = &H20000
Private Const STANDARD_RIGHTS_READ = (READ_CONTROL)
Private Const STANDARD_RIGHTS_WRITE = (READ_CONTROL)
Private Const KEY_CREATE_LINK = &H20
Private Const KEY_CREATE_SUB_KEY = &H4
Private Const KEY_ENUMERATE_SUB_KEYS = &H8
Private Const KEY_EVENT = &H1
Private Const KEY_NOTIFY = &H10
Private Const KEY_SET_VALUE = &H2
Private Const KEY_QUERY_VALUE = &H1
Private Const KEY_READ = ((STANDARD_RIGHTS_READ Or KEY_QUERY_VALUE Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY) And (Not SYNCHRONIZE))
Private Const KEY_EXECUTE = (KEY_READ)
Private Const KEY_WRITE = ((STANDARD_RIGHTS_WRITE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY) And (Not SYNCHRONIZE))
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))
'Costanti globali per le chiavi delle operazioni
Private Declare Function OSRegCloseKey Lib "advapi32" Alias "RegCloseKey" (ByVal hkey As Long) As Long
Private Declare Function OSRegCreateKey Lib "advapi32" Alias "RegCreateKeyA" (ByVal hkey As Long, ByVal lpszSubKey As String, phkResult As Long) As Long
Private Declare Function OSRegDeleteKey Lib "advapi32" Alias "RegDeleteKeyA" (ByVal hkey As Long, ByVal lpszSubKey As String) As Long
Private Declare Function OSRegEnumKey Lib "advapi32" Alias "RegEnumKeyA" (ByVal hkey As Long, ByVal iSubKey As Long, ByVal lpszName As String, ByVal cchName As Long) As Long
Private Declare Function OSRegOpenKey Lib "advapi32" Alias "RegOpenKeyA" (ByVal hkey As Long, ByVal lpszSubKey As String, phkResult As Long) As Long
Private Declare Function OSRegQueryValueEx 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
Private Declare Function OSRegSetValueEx 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
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
Private Declare Function OSRegEnumValue 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 OSRegFlushKey Lib "advapi32.dll" (ByVal hkey As Long) As Long
Private Declare Function OSRegOpenKeyEx 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
'proprieta' pubbliche
Public MasterKey As Long 'chiave principale HKEY_...
Public Key As String 'percorso in esame es.:Software\Microsoft
Public NameValue As String 'Nome della variabile da leggere/scrivere
Public NameKey As String 'Nome della key ricercata
Public STRValue As String 'Valore tipo stringa letto o da scrivere
Public DWordValue As Long 'Valore tipo DWORD letto o da scrivere
Public tipo As Long 'tipo di dati identificato
'legge il nome delle variabili in una key
'restituisce false se il valore idx non esiste
Public Function REnumValue(ByVal lCurIdx As Long) As Boolean
Dim lKeyHandle As Long, lResult As Long
Dim sValue As String, sResult As String
Dim lValueLen As Long, lData As Long, lDataLen As Long
Dim tipoVal As Long
lValueLen = 2000
lDataLen = 2000
REnumValue = False
If OSRegOpenKeyEx(MasterKey, Key$, 0&, KEY_QUERY_VALUE, lKeyHandle) = ERROR_SUCCESS Then
sValue$ = String(lValueLen, 0)
lResult = OSRegEnumValue(lKeyHandle, lCurIdx, ByVal sValue$, lValueLen, 0&, tipoVal, ByVal lData, lDataLen)
If lResult = ERROR_SUCCESS Then
NameValue$ = Left(sValue$, lValueLen)
tipo = tipoVal
REnumValue = True
End If
Call RegCloseKey(lKeyHandle)
End If
End Function
'legge il nome della key numero idx
'restituisce false se la key idx non esiste
Public Function REnumKey(ByVal idx As Long) As Boolean
Dim ret As Long
Dim result As String * 255
Dim handle As Long
REnumKey = False
If OSRegOpenKey(MasterKey, Key, handle) = ERROR_SUCCESS Then
ret = OSRegEnumKey(handle, idx, result$, 255&)
If ret = ERROR_SUCCESS Then
NameKey$ = StripTerminator(result$)
REnumKey = True
End If
Call RegCloseKey(handle)
End If
End Function
'cancella la chiave specificata in masterkey,key dal registro
'ritorna true se l'operazione riesce
Public Function RDelKey() As Boolean
Dim result As Long
RDelKey = False
result = RegDeleteKey(MasterKey, Key$)
If result = ERROR_SUCCESS Then
RDelKey = True
End If
End Function
'cancella il valore specificato da masterkey,key e NameValue dal registro
Public Function RDelValue() As Boolean
Dim handle As Long
Dim result As Long
RDelValue = False
If OSRegOpenKey(MasterKey, Key, handle) = ERROR_SUCCESS Then
result = RegDeleteValue(handle, NameValue$)
Call OSRegCloseKey(handle)
If result = ERROR_SUCCESS Then
RDelValue = True
End If
End If
End Function
'scrive un valore di tipo intero (DWORD) nel registro
'restituisce true se l'operazione riesce
' se il valore non esiste viene creato
' se il valore da settare non e' di tipo DWORD viene convertito
Public Function RSetDWord() As Boolean
Dim handle As Long
Dim result As Boolean
RSetDWord = False
If OSRegOpenKey(MasterKey, Key, handle) = ERROR_SUCCESS Then
result = RegSetNumericValue(handle, NameValue, DWordValue)
Call OSRegCloseKey(handle)
If result Then
RSetDWord = True
End If
End If
End Function
'legge un valore di tipo intero (DWORD) dal registro
'restituisce true se l'operazione riesce
' inserisce il valore letto in DWordValue e il corrispondente
' valore esadecimale in STRValue
Public Function RGetDWord() As Boolean
Dim errore As Long
Dim Haperto As Long
errore = RegOpenKey(MasterKey, Key$, Haperto)
If errore Then
If RegQueryIntValue(Haperto, NameValue$, DWordValue) Then
STRValue$ = Hex(DWordValue)
RGetDWord = True
Else
RGetDWord = False
End If
errore = RegCloseKey(Haperto)
Else
RGetDWord = False
End If
End Function
'crea la chiave specificata da MasterKey e da Key, solo se non esiste
' ritorna true se la chiave c'e' o gia c'era
'questa funzione crea anche piu di un livello alla volta automaticamente.
Public Function RCreateKey() As Boolean
Dim Exist As Boolean
Dim lResult As Long
Dim phkResult As Long
RCreateKey = True
If OSRegOpenKey(MasterKey, Key, phkResult) = ERROR_SUCCESS Then
Call OSRegCloseKey(phkResult)
Exist = True
Else
Exist = False
End If
If Not Exist Then
lResult = OSRegCreateKey(MasterKey, Key, phkResult)
If lResult = ERROR_SUCCESS Then
Call OSRegCloseKey(phkResult)
RCreateKey = True
Else
RCreateKey = False
End If
End If
End Function
'questa funzione legge la variabile indicata nelle proprietà della classe
' e restituisce il suo valore nella proprietà "Value"
'restituisce true se è possibile leggere la variabile
'es.: MasterKay=HKEY_CURRENT_USER
' Key = "Software\Microsoft\Windows\CurrentVersion\GrpConv
' NameValue = "Log"
'con questi settaggi STRValue verra' settato con il valore di "Log"
Public Function RGetString() As Boolean
Dim errore As Long
Dim Haperto As Long
errore = RegOpenKey(MasterKey, Key$, Haperto)
If errore Then
If RegQueryStringValue(Haperto, NameValue$, STRValue$) Then
RGetString = True
Else
RGetString = False
End If
errore = RegCloseKey(Haperto)
Else
RGetString = False
End If
End Function
'setta un valore in una variabile di registro, se tale variabile non esiste la crea
Public Function RSetString() As Boolean
Dim handle As Long
Dim result As Boolean
RSetString = False
If OSRegOpenKey(MasterKey, Key, handle) = ERROR_SUCCESS Then
result = RegSetStringValue(handle, NameValue, STRValue$)
Call OSRegCloseKey(handle)
If result Then
RSetString = True
End If
End If
End Function
'verifica l'esistenza di una chiave nel registro
' es: Software\Microsoft (esiste!)
'MasterKey deve corrispondere alla chiave principale del registro (es.:HKEY_...)
'Key deve corrispondere al percorso da verificare (es.: Software\Microsoft)
Public Function RGetKey() As Boolean
Dim handle As Long
If OSRegOpenKey(MasterKey, Key, handle) = ERROR_SUCCESS Then
Call OSRegCloseKey(handle)
RGetKey = True
Else
RGetKey = False
End If
End Function
'-----------------------------------------------------------
' Funzione: RegCloseKey
'
' Chiude una chiave di registro aperta.
'
' Restituisce: True se l'operazione riesce, False in caso
' contrario.
'-----------------------------------------------------------
'
Private Function RegCloseKey(ByVal hkey As Long) As Boolean
Dim lResult As Long
On Error GoTo 0
lResult = OSRegCloseKey(hkey)
RegCloseKey = (lResult = ERROR_SUCCESS)
End Function
'-----------------------------------------------------------
' Funzione: RegCreateKey
'
' Apre (crea se esiste già) una chiave nel registro di
' configurazione del sistema.
'
' In: [hkey]: HKEY del livello superiore.
' [lpszSubKeyPermanent]: prima parte della sottochiave di
' 'hkey' che verrà creata o aperta. L'utilità di
' rimozione dell'applicazione (solo 32 bit) non eliminerà
' mai alcuna parte di questa sottochiave. Non può essere
' una stringa vuota ("").
'
' Out: [phkResult]: HKEY della chiave appena aperta o creata.
'
' Restituisce: True se l'operazione di creazione/apertura della chiave
' è riuscita, False in caso contrario. Se l'operazione riesce,
' phkResult viene impostato sull'handle della chiave.
'
'-----------------------------------------------------------
Private Function RegCreateKey(ByVal hkey As Long, ByVal lpszSubKeyPermanent As String, phkResult As Long) As Boolean
Dim lResult As Long
Dim strHkey As String
Dim fLog As Boolean
Dim strSubKeyFull As String
On Error GoTo 0
If lpszSubKeyPermanent = "" Then
RegCreateKey = False 'Errore: lpszSubKeyPermanent non può essere = ""
Exit Function
End If
lResult = OSRegCreateKey(hkey, strSubKeyFull, phkResult)
If lResult = ERROR_SUCCESS Then
RegCreateKey = True
Else
RegCreateKey = False
End If
End Function
'-----------------------------------------------------------
' Funzione: RegOpenKey
'
' Apre una chiave esistente nel registro di configurazione
' del sistema.
'
' Restituisce: True se la chiave viene aperta correttamente,
' False in caso contrario. Se l'operazione riesce, phkResult
' viene impostato sull'handle della chiave.
'-----------------------------------------------------------
'
Private Function RegOpenKey(ByVal hkey As Long, ByVal lpszSubKey As String, phkResult As Long) As Boolean
Dim lResult As Long
Dim strHkey As String
On Error GoTo 0
lResult = OSRegOpenKey(hkey, lpszSubKey, phkResult)
If lResult = ERROR_SUCCESS Then
RegOpenKey = True
Else
RegOpenKey = False
End If
End Function
'----------------------------------------------------------
' Funzione: RegPathWinPrograms
'
' Restituisce il nome della chiave del registro di configurazione
' "\HKEY_CURRENT_USER\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders"
'----------------------------------------------------------
Private Function RegPathWinPrograms() As String
RegPathWinPrograms = RegPathWinCurrentVersion() & "\Explorer\Shell Folders"
End Function
'----------------------------------------------------------
' Funzione: RegPathWinCurrentVersion
'
' Restituisce il nome della chiave del registro di configurazione
' "\HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion"
'----------------------------------------------------------
Private Function RegPathWinCurrentVersion() As String
RegPathWinCurrentVersion = "SOFTWARE\Microsoft\Windows\CurrentVersion"
End Function
'----------------------------------------------------------
' Funzione: RegQueryIntValue
'
' Recupera i dati di tipo Integer per un valore specificato
' (strValueName = nome) o non specificato (strValueName = "")
' incluso in una chiave del registro. Se il valore specificato
' esiste, ma i relativi dati non corrispondono a una REG_DWORD,
' questa funzione non restituisce alcun risultato.
'
' Restituisce: True se l'operazione riesce, False in caso
' contrario. Nel primo caso lData viene impostato sul valore
' dei dati numerico.
'
'----------------------------------------------------------
Private Function RegQueryIntValue(ByVal hkey As Long, ByVal strValueName As String, ByRef lData As Long) As Boolean
Dim lResult As Long
Dim lValueType As Long
Dim lBuf As Long
Dim lDataBufSize As Long
RegQueryIntValue = False
On Error GoTo 0
' Recupera il tipo e la lunghezza dei dati.
lDataBufSize = 4
lResult = OSRegQueryValueEx(hkey, strValueName, 0&, lValueType, lBuf, lDataBufSize)
If lResult = ERROR_SUCCESS Then
If lValueType = REG_DWORD Then
lData = lBuf
RegQueryIntValue = True
End If
End If
End Function
' Funzione: RegQueryStringValue
'
' Recupera i dati di tipo String relativi a un valore specificato
' (strValueName = nome) o non specificato (strValueName = "")
' incluso in una chiave del registro. Se il valore specificato
' esiste, ma i relativi dati non sono di tipo String, questa
' funzione non restituisce alcun risultato.
'
' NOTA: per i sistemi a 16 bit, strValueName deve essere "" (anche
' se il parametro non viene eliminato per motivi di compatibilità
' con il codice sorgente).
'
' Restituisce: True se l'operazione riesce, False in caso contrario.
' Nel primo caso strData viene impostata su un valore di dati di
' tipo String.
'
Private Function RegQueryStringValue(ByVal hkey As Long, ByVal strValueName As String, strData As String) As Boolean
Dim lResult As Long
Dim lValueType As Long
Dim strBuf As String
Dim lDataBufSize As Long
RegQueryStringValue = False
On Error GoTo 0
' Recupera il tipo e la lunghezza dei dati.
lResult = OSRegQueryValueEx(hkey, strValueName, 0&, lValueType, ByVal 0&, lDataBufSize)
If lResult = ERROR_SUCCESS Then
If lValueType = REG_SZ Then
strBuf = String(lDataBufSize, " ")
lResult = OSRegQueryValueEx(hkey, strValueName, 0&, 0&, ByVal strBuf, lDataBufSize)
If lResult = ERROR_SUCCESS Then
RegQueryStringValue = True
strData = StripTerminator(strBuf)
End If
End If
End If
End Function
' Funzione: RegSetNumericValue
'
' Associa un valore specificato (strValueName = nome) o non specificato
' (strValueName = "") a una chiave del registro di configurazione.
'
' Se fLog manca o è True, questa operazione viene registrata nel file registro
' e il valore verrà eliminato dal programma di disinstallazione dell'applicazione.
'
' Restituisce: True se l'operazione riesce, False in caso contrario.
'
Private Function RegSetNumericValue(ByVal hkey As Long, ByVal strValueName As String, ByVal lData As Long) As Boolean
Dim lResult As Long
Dim strHkey As String
On Error GoTo 0
lResult = OSRegSetValueEx(hkey, strValueName, 0&, REG_DWORD, lData, 4)
If lResult = ERROR_SUCCESS Then
RegSetNumericValue = True
Else
RegSetNumericValue = False
End If
End Function
' Funzione: RegSetStringValue
'
' Associa un valore specificato (strValueName = nome) o non specificato
' (strValueName = "") a una chiave del registro di configurazione.
' Restituisce: True se l'operazione riesce, False in caso contrario.
'
Private Function RegSetStringValue(ByVal hkey As Long, ByVal strValueName As String, ByVal strData As String) As Boolean
Dim lResult As Long
Dim strHkey As String
On Error GoTo 0
If hkey = 0 Then
Exit Function
End If
lResult = OSRegSetValueEx(hkey, strValueName, 0&, REG_SZ, ByVal strData, LenB(StrConv(strData, vbFromUnicode)) + 1)
If lResult = ERROR_SUCCESS Then
RegSetStringValue = True
Else
RegSetStringValue = False
End If
End Function
'In base a una HKEY già definita, restituisce la stringa di testo che rappresenta
'la chiave oppure restituisce "".
Private Function strGetPredefinedHKEYString(ByVal hkey As Long) As String
Select Case hkey
Case HKEY_CLASSES_ROOT
strGetPredefinedHKEYString = "HKEY_CLASSES_ROOT"
Case HKEY_CURRENT_USER
strGetPredefinedHKEYString = "HKEY_CURRENT_USER"
Case HKEY_LOCAL_MACHINE
strGetPredefinedHKEYString = "HKEY_LOCAL_MACHINE"
Case HKEY_USERS
strGetPredefinedHKEYString = "HKEY_USERS"
'Fine delle possibilità.
End Select
End Function
'-----------------------------------------------------------
' FUNZIONE: StripTerminator
'
' Restituisce una stringa senza terminatori zero. In genere
' si tratta di una stringa restituita da una chiamata ad
' un'API di Windows.
'
' IN: [strString] - Stringa da cui rimuovere il terminatore
'
' Restituisce: Il valore della stringa passata senza eventuali
' zero finali.
'-----------------------------------------------------------
'
Private Function StripTerminator(ByVal strString As String) As String
Dim intZeroPos As Integer
intZeroPos = InStr(strString, Chr$(0))
If intZeroPos > 0 Then
StripTerminator = Left$(strString, intZeroPos - 1)
Else
StripTerminator = strString
End If
End Function
oubt:
