Function addTrustedLocation(strFolder As String, strLocationDescription As String, blnAllowSubFolders As Boolean, strOfficeApp As String, strOfficeVersion As String) As Boolean
'(developed july 2019 by Gert De Wilde)
addTrustedLocation = False
Const HKEY_CURRENT_USER = &H80000001
Dim strParentKey As String, intLocCounter As Long, objRegistry As Object, varChildKey, arrChildKeys
Dim strNewKey As String, tmpValue As String, keyAvailable As Boolean, lngStep As Long
On Error GoTo Hdl
lngStep = 10
tmpValue = ""
Select Case strOfficeApp
Case "Word"
'strParentKey = "Software\Microsoft\Office\14.0\Word\Security\Trusted Locations"
strParentKey = "Software\Microsoft\Office\" & strOfficeVersion & "\Word\Security\Trusted Locations"
Case "Excel"
'strParentKey = "Software\Microsoft\Office\14.0\Excel\Security\Trusted Locations"
strParentKey = "Software\Microsoft\Office\" & strOfficeVersion & "\Excel\Security\Trusted Locations"
Case "Access"
'strParentKey = "Software\Microsoft\Office\14.0\Access\Security\Trusted Locations"
strParentKey = "Software\Microsoft\Office\" & strOfficeVersion & "\Access\Security\Trusted Locations"
Case Else
'MsgBox("The application you specified is not covered by this procedure", , "Trusted location definition")
Exit Function
End Select
intLocCounter = 0
lngStep = 15
'objRegistry = GetObject("winmgmts:\\.\root\default:StdRegProv")
Set objRegistry = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv") '10jul19
lngStep = 20
Call objRegistry.EnumKey(HKEY_CURRENT_USER, strParentKey, arrChildKeys)
lngStep = 25
If Not isArray(arrChildKeys) Then
'the Trusted Location folder does not exist and needs to be created
' if only Acces Runtime is available, then the 'Trusted Locations' node does not yet exist
'so create this node (will not cause error if already available) and one childkey
'just to assure a childkey collection
Call objRegistry.CreateKey(HKEY_CURRENT_USER, strParentKey)
Call objRegistry.CreateKey(HKEY_CURRENT_USER, strParentKey & "\Location9")
Call objRegistry.SetStringValue(HKEY_CURRENT_USER, strParentKey & "\Location9", "Path", strFolder)
objRegistry = Nothing
arrChildKeys = Nothing
Set objRegistry = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv")
Call objRegistry.EnumKey(HKEY_CURRENT_USER, strParentKey, arrChildKeys)
End If
lngStep = 26
If isArray(arrChildKeys) Then
'if a key with the specified path aleady exists, delete this key to be replaced
For Each varChildKey In arrChildKeys
lngStep = lngStep + 1
Call objRegistry.GetStringValue(HKEY_CURRENT_USER, strParentKey & "\" & varChildKey, "Path", tmpValue)
'Console.WriteLine(tmpValue)
If tmpValue = strFolder Then
Call objRegistry.DeleteKey(HKEY_CURRENT_USER, strParentKey & "\" & varChildKey)
End If
Next
End If
lngStep = 30
'refresh the array in case one has been deleted
Call objRegistry.EnumKey(HKEY_CURRENT_USER, strParentKey, arrChildKeys)
'keep track of child key numbering
'missing holes should be filled so look for the first available locationX
'first look if a slot between 0 and 9 is available
If Not isArray(arrChildKeys) Then
intLocCounter = 0
keyAvailable = True
Else
If isArray(arrChildKeys) Then 'if no childkey array, skip this check
For intLocCounter = 0 To 9
keyAvailable = True
For Each varChildKey In arrChildKeys
If CInt(Mid(varChildKey, 9)) = intLocCounter Then keyAvailable = False
Next
If keyAvailable = True Then Exit For
Next
End If
End If
lngStep = 40
'else take the next available
If keyAvailable = False Then
For Each varChildKey In arrChildKeys
If CInt(Mid(varChildKey, 9)) > intLocCounter Then
intLocCounter = CInt(Mid(varChildKey, 9))
End If
Next
intLocCounter = intLocCounter + 1
End If
'now choose the key
strNewKey = strParentKey & "\Location" & CStr(intLocCounter)
lngStep = 50
Call objRegistry.CreateKey(HKEY_CURRENT_USER, strNewKey)
Call objRegistry.SetStringValue(HKEY_CURRENT_USER, strNewKey, "Path", strFolder)
Call objRegistry.SetStringValue(HKEY_CURRENT_USER, strNewKey, "Description", strLocationDescription)
If blnAllowSubFolders Then
Call objRegistry.SetDWORDValue(HKEY_CURRENT_USER, strNewKey, "AllowSubFolders", 1)
End If
lngStep = 60
addTrustedLocation = True
Exit Function
Hdl:
MsgBox ("Error creating trusted location " & strFolder & " in step " & lngStep & " : " & Err & " " & Err.Description)
End Function
@Cornelis77 You can add trusted locations with VBA code, from within your application. They can be written as registry keys. I once spent a day to create the VBA function addTrustedLocation below. In short, it checks if the specified location already exists and if not, creates it. Note that your environment may block the creation of trusted locations on the network.
