Writing to Window's Registry 1

[margoo]

Does anyone know how to write to Window's Registry? I'm trying to prevent my Access mde from being copied.

 

[aphisgirl]

I think the following could help you out.

Option Compare Database
Option Explicit

Private MAPISession As MAPI.Session
Private MAPIMessage As Message
Private MAPIRecipient As MAPI.Recipient
Private MAPIAttachment As MAPI.Attachment
Private reciparray
Private strFileName As String


Private Type OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long
szCSDVersion As String * 128
End Type

Private Const REG_SZ As Long = 1
Private Const REG_DWORD As Long = 4
Private Const HKEY_CURRENT_USER = &H80000001
Private Const ERROR_NONE = 0
Private Const ERROR_BADDB = 1
Private Const ERROR_BADKEY = 2
Private Const ERROR_CANTOPEN = 3
Private Const ERROR_CANTREAD = 4
Private Const ERROR_CANTWRITE = 5
Private Const ERROR_OUTOFMEMORY = 6
Private Const ERROR_INVALID_PARAMETER = 7
Private Const ERROR_ACCESS_DENIED = 8
Private Const ERROR_INVALID_PARAMETERS = 87
Private Const ERROR_NO_MORE_ITEMS = 259
Private Const KEY_ALL_ACCESS = &H3F
Private Const REG_OPTION_NON_VOLATILE = 0

Private Declare Function GetVersionEx Lib "kernel32" _
Alias "GetVersionExA" _
(ByRef lpVersionInformation As OSVERSIONINFO) As Long


Private Declare Function RegCloseKey Lib "advapi32.dll" _
(ByVal hKey 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 GetTempPath Lib "kernel32" _
Alias "GetTempPathA" (ByVal nBufferLength As Long, _
ByVal lpBuffer As String) As Long

Public Enum accSendObjectOutputFormat
accOutputRTF = 1
accOutputTXT = 2
accOutputSNP = 3
accOutputXLS = 4
End Enum

 

[TardisInc]

You might as well have the code that makes it all work; the rest of the DECLAREs you need are here, also.

Larry Wilson
TARDIS Systems, Inc.
Dallas, TX

Public Const ERROR_SUCCESS = 0
Public Const ERROR_NONE = 0
Public Const ERROR_BADDB = 1
Public Const ERROR_BADKEY = 2
Public Const ERROR_CANTOPEN = 3
Public Const ERROR_CANTREAD = 4
Public Const ERROR_CANTWRITE = 5
Public Const ERROR_OUTOFMEMORY = 6
Public Const ERROR_INVALID_PARAMETER = 7
Public Const ERROR_ACCESS_DENIED = 8
Public Const ERROR_INVALID_PARAMETERS = 87
Public Const ERROR_NO_MORE_ITEMS = 259

Public Const Delete = &H10000
Public Const READ_CONTROL = &H20000
Public Const WRITE_DAC = &H40000
Public Const WRITE_OWNER = &H80000
Public Const SYNCHRONIZE = &H100000

Public Const STANDARD_RIGHTS_READ = READ_CONTROL
Public Const STANDARD_RIGHTS_WRITE = READ_CONTROL
Public Const STANDARD_RIGHTS_EXECUTE = READ_CONTROL
Public Const STANDARD_RIGHTS_ALL = &H1F0000
Public Const SPECIFIC_RIGHTS_ALL = &HFFFF&

Public Const APPLICATION_ERROR_MASK = &H20000000
Public Const ERROR_SEVERITY_SUCCESS = &H0&
Public Const ERROR_SEVERITY_INFORMATIONAL = &H40000000
Public Const ERROR_SEVERITY_WARNING = &H80000000
Public Const ERROR_SEVERITY_ERROR = &HC0000000

Public Const HKEY_CLASSES_ROOT = &H80000000
Public Const HKEY_CURRENT_USER = &H80000001
Public Const HKEY_LOCAL_MACHINE = &H80000002
Public Const HKEY_USERS = &H80000003
Public Const HKEY_PERFORMANCE_DATA = &H80000004
Public Const HKEY_CURRENT_CONFIG = &H80000005
Public Const HKEY_DYN_DATA = &H80000006

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 KEY_READ = STANDARD_RIGHTS_READ Or KEY_QUERY_VALUE Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY And Not SYNCHRONIZE
Public Const KEY_WRITE = STANDARD_RIGHTS_WRITE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY And Not SYNCHRONIZE
Public Const KEY_EXECUTE = KEY_READ And Not SYNCHRONIZE
Public 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

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
Const REG_OPTION_NON_VOLATILE = 0 ' Key is preserved when system is rebooted

Public Type FileTime
dwLowDateTime As Long
dwHightDateTime As Long
End Type

Public Declare Function RegEnumKeyEx _
Lib "advapi32" Alias "RegEnumKeyExA" _
(ByVal hKey As Long, ByVal iSubkey As Long, _
ByVal lpszName As String, ByRef lpcchName As Long, _
ByVal lpdwReserved As Long, ByVal lpszClass As String, _
ByRef lpcchClass As Long, _
ByRef lpftLastWrite As FileTime) As Long

Public Declare Function RegQueryInfoKey Lib "advapi32" Alias "RegQueryInfoKeyA" ( _
ByVal hKey As Long, ByVal lpszClass As String, _
ByRef lpcchClass As Long, ByVal lpdwReserved As Long, _
ByRef lpcSubKeys As Long, ByRef lpcchMaxSubkey As Long, _
ByRef lpcchMaxClass As Long, ByRef lpcValeus As Long, _
ByRef lpcchMaxValueName As Long, _
ByRef lpcbMaxValueData As Long, _
ByRef lpcbSecurityDescriptor As Long, _
ByRef lpftLastWriteTime As FileTime) As Long

Public Declare Function RegEnumKey Lib "advapi32" Alias "RegEnumKeyA" ( _
ByVal hKey As Long, ByVal iSubkey As Long, _
ByVal lpszName As String, ByVal cchName As Long) As Long

Public Declare Function RegEnumValue Lib "advapi32" Alias "RegEnumValueA" ( _
ByVal hKey As Long, ByVal iValue As Long, _
ByVal lpszValue As String, ByRef lpcchValue As Long, _
ByVal lpdwReserved As Long, ByRef lpdwType As Long, _
lpbData As Any, ByRef lpcbData As Long) As Long

Public Declare Function RegOpenKeyEx Lib "advapi32" Alias "RegOpenKeyExA" ( _
ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, _
ByVal samDesired As Long, ByRef phkResult As Long) As Long


Public Declare Function RegQueryValueEx Lib "advapi32" Alias "RegQueryValueExA" ( _
ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, _
ByRef lpType As Long, ByVal lpData As String, ByRef lpcbData As Long) As Long


Public Declare Function RegCloseKey Lib "advapi32" (ByVal hKey As Long) As Long
' Note that if you declare the lpData pa
' rameter as String in RegSetValueEx, you
' must pass it ByVal.

Public Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" ( _
ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, _
ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As Long

Public Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" ( _
ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long

Public Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" ( _
ByVal hKey As Long, ByVal lpValueName As String) As Long

Public Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" ( _
ByVal hKey As Long, ByVal lpSubKey As String) As Long

Public Function tsiRegGetValue(ByVal KeyRoot As Long, ByVal KeyName As String, ByVal SubKeyRef As String) As String

Dim i As Long, rc As Long, hKey As Long, KeyValType As Long, lStart As Long, lEnd As Long
Dim tmpVal As String, KeyValSize As Long, sTempPiece As String, KeyVal As String

On Error GoTo GetKeyError
rc = RegOpenKeyEx(KeyRoot, KeyName, 0, KEY_READ, hKey)
If (rc <> ERROR_SUCCESS) Then GoTo GetKeyError

tmpVal = String$(1024, 0)
KeyValSize = 1024

rc = RegQueryValueEx(hKey, SubKeyRef, 0, KeyValType, tmpVal, KeyValSize)
If (rc <> ERROR_SUCCESS) Then GoTo GetKeyError

If (Asc(Mid(tmpVal, KeyValSize, 1)) = 0) Then
tmpVal = Left(tmpVal, KeyValSize - 1)
Else
tmpVal = Left(tmpVal, KeyValSize)
End If

Select Case KeyValType
Case REG_DWORD
For i = Len(tmpVal) To 1 Step -1
KeyVal = KeyVal + Format(Hex(Asc(Mid(tmpVal, i, 1))), "00")
Next
KeyVal = Format$("&h" + KeyVal)
Case REG_SZ
KeyVal = tmpVal
Case REG_BINARY
lStart = 1
lEnd = InStr(lStart, tmpVal, Chr(0))
Do Until lEnd = 0
KeyVal = KeyVal & Mid$(tmpVal, lStart, lEnd - lStart)
' do something
lStart = lEnd + 1
lEnd = InStr(lStart, tmpVal, Chr(0))
Loop
' loop thru the string, converting; first example below
'X = InStr(strValue, Chr(0)) 'X should equal 2, which is the
'first location of the NULL
'character.
End Select
tsiRegGetValue = KeyVal
rc = RegCloseKey(hKey)
Exit Function

GetKeyError:
tsiRegGetValue = vbNull
'Err.Raise 1, "RegGetSubKeyValue", "Error getting a REGISTRY value"
rc = RegCloseKey(hKey)
End Function
Public Function tsiRegGetValues(KeyRoot As Long, KeyName As String) As String
' Returns a semi-colon separated list of all of
' the values of this key

Dim strRet As String, strClassName As String, strValue As String
Dim lngRet As Long, lngClassName As Long, lngCSubKeys As Long, lngMaxSubKey As Long
Dim lngMaxClass As Long, lngCValues As Long, lngMaxValueName As Long
Dim lngMaxValueData As Long, lngSecurityDescriptor As Long, i As Long
Dim ftLastWrite As FileTime
Dim lngValue As Long, retCode As Long, lngType As Long, lngLen As Long, hKey As Long

retCode = RegOpenKeyEx(KeyRoot, KeyName, 0, KEY_READ, hKey)
If (retCode <> ERROR_SUCCESS) Then GoTo GetKeyError

strRet = ""
strClassName = Space$(256)
lngClassName = Len(strClassName)
retCode = RegQueryInfoKey(hKey, strClassName, lngClassName, 0&, lngCSubKeys, lngMaxSubKey, _
lngMaxClass, lngCValues, lngMaxValueName, _
lngMaxValueData, lngSecurityDescriptor, ftLastWrite)
Select Case retCode And APPLICATION_ERROR_MASK
Case ERROR_SEVERITY_SUCCESS
For i = 0 To lngCValues - 1
strValue = Space$(lngMaxValueName)
lngValue = Len(strValue) + 1
retCode = RegEnumValue(hKey, i, strValue, lngValue, ByVal 0&, lngType, ByVal 0&, lngLen)
Select Case retCode And APPLICATION_ERROR_MASK
Case ERROR_SEVERITY_SUCCESS
Case Else
Stop
Exit For
End Select
strValue = Left$(strValue, lngValue)
strRet = strRet & "'" & strValue & "';"
Next i
Case Else
Stop
End Select

tsiRegGetValues = strRet
Exit Function

GetKeyError:
tsiRegGetValues = ""
retCode = RegCloseKey(hKey)
End Function
Public Function tsiRegSetValue(KeyRoot As Long, KeyName As String, lType As Long, _
SubKeyRef As String, KeyVal As Variant) As Boolean
Dim rc As Long, hKey As Long
rc = RegOpenKeyEx(KeyRoot, KeyName, 0, KEY_ALL_ACCESS, hKey)
If (rc <> ERROR_SUCCESS) Then
Call RegCreateKey(KeyRoot, KeyName, hKey)
End If

Select Case lType
Case REG_SZ
rc = RegSetValueEx(hKey, SubKeyRef, 0&, REG_SZ, ByVal CStr(KeyVal & Chr$(0)), Len(KeyVal))
Case REG_BINARY
rc = RegSetValueEx(hKey, SubKeyRef, 0&, REG_BINARY, ByVal CStr(KeyVal & Chr$(0)), Len(KeyVal))
Case REG_DWORD
rc = RegSetValueEx(hKey, SubKeyRef, 0&, REG_DWORD, CLng(KeyVal), 4)
End Select
If (rc <> ERROR_SUCCESS) Then GoTo SetKeyError

tsiRegSetValue = True
rc = RegCloseKey(hKey)
Exit Function

SetKeyError:
KeyVal = ""
tsiRegSetValue = False
rc = RegCloseKey(hKey)
End Function

Public Function tsiRegDeleteValue(KeyName As String, SubKeyRef As String) As Boolean
Dim rc As Long, hKey As Long

rc = RegOpenKeyEx(HKEY_LOCAL_MACHINE, KeyName, 0, KEY_ALL_ACCESS, hKey)

If (rc = ERROR_SUCCESS) Then
rc = RegDeleteValue(hKey, SubKeyRef)
If (rc = ERROR_SUCCESS) Then
tsiRegDeleteValue = True
Exit Function
End If
End If

DeleteKeyError:
tsiRegDeleteValue = False
End Function
Public Function tsiRegDeleteKey(KeyRoot As Long, KeyName As String) As Boolean
Dim rc As Long
'All sub keys must be deleted for this t
' o work.
'If you create key under your original k
' ey, you
'need to delete it forst.
rc = RegDeleteKey(KeyRoot, KeyName)
tsiRegDeleteKey = (rc = ERROR_SUCCESS)
End Function
Public Function tsiRegDeleteAllKeys(KeyRoot As Long, KeyName As String) As Boolean
Dim rc As Long
' iterate thru the keychain from the bottom, deleting

rc = RegDeleteKey(KeyRoot, KeyName)
tsiRegDeleteAllKeys = (rc = ERROR_SUCCESS)
End Function
Public Function tsiRegGetKeys(KeyRoot As Long, KeyName As String) As String
' Returns a semi-colon separated list of all of
' the sub-keys of this key
Dim strRet As String, strClassName As String, strKey As String, strClass As String
Dim lngRet As Long, lngClassName As Long, lngCSubKeys As Long, lngMaxSubKey As Long
Dim lngMaxClass As Long, lngCValues As Long, lngMaxValueName As Long
Dim lngMaxValueData As Long, lngSecurityDescriptor As Long, i As Long
Dim ftLastWrite As FileTime
Dim lngKey As Long, lngClass As Long, retCode As Long, hKey As Long

' get the key from the path
retCode = RegOpenKeyEx(KeyRoot, KeyName, 0, KEY_READ, hKey)
If (retCode <> ERROR_SUCCESS) Then GoTo GetKeyError

strRet = ""
strClassName = Space$(256)
lngClassName = Len(strClassName)
Call RegQueryInfoKey(hKey, strClassName, lngClassName, 0&, lngCSubKeys, lngMaxSubKey, _
lngMaxClass, lngCValues, lngMaxValueName, lngMaxValueData, lngSecurityDescriptor, ftLastWrite)
For i = 0 To lngCSubKeys - 1
strKey = Space$(lngMaxSubKey)
lngKey = Len(strKey) + 1
strClass = Space$(lngMaxClass)
lngClass = Len(strClass) + 1
retCode = RegEnumKeyEx(hKey, i, strKey, lngKey, 0&, strClass, lngClass, ftLastWrite)
Select Case retCode And APPLICATION_ERROR_MASK
Case ERROR_SEVERITY_SUCCESS
Case Else
Stop
Exit For
End Select
strKey = Left$(strKey, lngKey)
strRet = strRet & strKey & ";"
Next i

tsiRegGetKeys = strRet
Exit Function

GetKeyError:
tsiRegGetKeys = ""
retCode = RegCloseKey(hKey)
End Function