riti90
Registered User.
- Local time
- Today, 15:07
- Joined
- Dec 20, 2017
- Messages
- 44
Hi All,
I fount a piece of code for adding Trusted Locations via Code and did a few edits.
Hope it will come handy to someone.
Regards,
Margarit
I fount a piece of code for adding Trusted Locations via Code and did a few edits.
Hope it will come handy to someone.
Code:
Option Compare Database
Option Explicit
'Reading from the Registry:
'reads the value for the registry key i_RegKey
'if the key cannot be found, the return value is ""
Function RegKeyRead(i_RegKey As String) As String
Dim myWS As Object
On Error Resume Next
'access Windows scripting
Set myWS = CreateObject("WScript.Shell")
'read key from registry
RegKeyRead = myWS.RegRead(i_RegKey)
End Function
'Checking if a Registry key exists:
'returns True if the registry key i_RegKey was found
'and False if not
Function RegKeyExists(i_RegKey As String) As Boolean
Dim myWS As Object
On Error GoTo ErrorHandler
'access Windows scripting
Set myWS = CreateObject("WScript.Shell")
'try to read the registry key
myWS.RegRead i_RegKey
'key was found
RegKeyExists = True
Exit Function
ErrorHandler:
'key was not found
RegKeyExists = False
End Function
'Saving a Registry key:
'sets the registry key i_RegKey to the
'value i_Value with type i_Type
'if i_Type is omitted, the value will be saved as string
'if i_RegKey wasn't found, a new registry key will be created
Sub RegKeySave(i_RegKey As String, _
i_Value As String, _
Optional i_Type As String)
Dim myWS As Object
'access Windows scripting
Set myWS = CreateObject("WScript.Shell")
'write registry key
myWS.RegWrite i_RegKey, i_Value, i_Type
End Sub
'Deleting a key from the Registry:
'deletes i_RegKey from the registry
'returns True if the deletion was successful,
'and False if not (the key couldn't be found)
Function RegKeyDelete(i_RegKey As String) As Boolean
Dim myWS As Object
On Error GoTo ErrorHandler
'access Windows scripting
Set myWS = CreateObject("WScript.Shell")
'delete registry key
myWS.RegDelete i_RegKey
'deletion was successful
RegKeyDelete = True
Exit Function
ErrorHandler:
'deletion wasn't successful
RegKeyDelete = False
End Function
Function TestRegistry()
Dim myRegKey As String
Dim myRegDate As String
Dim myRegAllowFolders As String
Dim myRegDescription As String
Dim myRegKeyValue As String
Dim myRegAllowFoldersValue As String
Dim myRegDateValue As String
Dim myRegDescriptionValue As String
Dim myRegistryKey As String
Dim myDataType As String
Dim myDataTypeFolder As String
Dim strVersion As String
strVersion = Application.version
myRegistryKey = "HKEY_CURRENT_USER\Software\Microsoft\Office\" & strVersion & "\Access\Security\Trusted Locations\MyTrustedPath" '16.0 is Office 16/365, 12.0 is Office 2007
myRegKey = "HKEY_CURRENT_USER\Software\Microsoft\Office\" & strVersion & "\Access\Security\Trusted Locations\MyTrustedPath\Path"
myRegAllowFolders = "HKEY_CURRENT_USER\Software\Microsoft\Office\" & strVersion & "\Access\Security\Trusted Locations\MyTrustedPath\AllowSubFolders"
myRegDate = "HKEY_CURRENT_USER\Software\Microsoft\Office\" & strVersion & "\Access\Security\Trusted Locations\MyTrustedPath\Date"
myRegDescription = "HKEY_CURRENT_USER\Software\Microsoft\Office\" & strVersion & "\Access\Security\Trusted Locations\MyTrustedPath\Description"
myDataType = "REG_SZ"
myDataTypeFolder = "REG_DWORD"
myRegKeyValue = Application.CurrentProject.Path & "\"
myRegAllowFoldersValue = "00000001"
myRegDateValue = (Now())
myRegDescriptionValue = "Your Description...."
If myRegistryKey = "" Then Exit Function
'check if key exists
If RegKeyExists(myRegistryKey) = True Or RegKeyExists(myRegKey) = True Or RegKeyExists(myRegAllowFolders) = True Or RegKeyExists(myRegDate) = True Then
Exit Function
Else
If myRegKeyValue <> "" Then
'save/create registry key with new value
RegKeySave myRegKey, myRegKeyValue, myDataType
RegKeySave myRegAllowFolders, myRegAllowFoldersValue, myDataTypeFolder
RegKeySave myRegDate, myRegDateValue, myDataType
RegKeySave myRegDescription, myRegDescriptionValue, myDataType
End If
End If
End FunctionRegards,
Margarit
