UtterAccess HomeUtterAccess Wiki

Welcome Guest ( Log In | Register )

Custom Search
Edit Discussion
> AddTrustedLocation    
Function Information
Applicable Versions

- Access 2007+
- Tested in Access 2013 x64 on Windows 7
- Use alternate code for Win8 64 Bit and Access 2013 64 Bit

Dependancies

- Visual Basic for Applications - Registry Permissions

See Also

- Trusted Locations (Article)

Access 2007 and Access 2010 use trusted locations as a security measure to help prevent users opening a database from an unknown source which could include malicious code. Typically, if you open a database that is not in a trusted location, Access will display a security message asking if you want to open the file.

With the full version of Access trusted locations can be added manually using the trust centre, however this option is not available if your users only have Access RunTime. This article and code provide a means to add a trusted location automatically.

The code, which should be called as part of the start up routine, e.g. from the AutoExec macro, searches the registry to see if the the current location of the database is included in the trusted locations list. If it is, the code exits. If not, the code adds the location in the first available trusted location slot available in the registry.

If the database file is opened from a non trusted location the Access security warning will be displayed and the code run when the database opens. Subsequently, as the trusted location will have been added, the Access security warning will no longer be displayed.



Code for Windows 7

CODE

Public Function AddTrustedLocation()
On Error GoTo err_proc
'WARNING:  THIS CODE MODIFIES THE REGISTRY
'sets registry key for 'trusted location'

  Dim intLocns As Integer
  Dim i As Integer
  Dim intNotUsed As Integer
  Dim strLnKey As String
  Dim reg As Object
  Dim strPath As String
  Dim strTitle as string
 
  strTitle = "Add Trusted Location"
  Set reg = CreateObject("wscript.shell")
  strPath = CurrentProject.Path

  'Specify the registry trusted locations path for the version of Access used
  strLnKey = "HKEY_CURRENT_USER\Software\Microsoft\Office\" & Format(Application.Version, "##,##0.0") & _
             "\Access\Security\Trusted Locations\Location"

On Error GoTo err_proc0
  'find top of range of trusted locations references in registry
  For i = 999 To 0 Step -1
      reg.RegRead strLnKey & i & "\Path"
      GoTo chckRegPths        'Reg.RegRead successful, location exists > check for path in all locations 0 - i.
checknext:
  Next
  MsgBox "Unexpected Error - No Registry Locations found", vbExclamation
  GoTo exit_proc
 
 
chckRegPths:
'Check if Currentdb path already a trusted location
'reg.RegRead fails before intlocns = i then the registry location is unused and
'will be used for new trusted location if path not already in registy

On Error GoTo err_proc1:
  For intLocns = 1 To i
      reg.RegRead strLnKey & intLocns & "\Path"
      'If Path already in registry -> exit
      If InStr(1, reg.RegRead(strLnKey & intLocns & "\Path"), strPath) = 1 Then GoTo exit_proc
NextLocn:
  Next
 
  If intLocns = 999 Then
      MsgBox "Location count exceeded - unable to write trusted location to registry", vbInformation, strTitle
      GoTo exit_proc
  End If
  'if no unused location found then set new location for path
  If intNotUsed = 0 Then intNotUsed = i + 1
 
'Write Trusted Location regstry key to unused location in registry
On Error GoTo err_proc:
  strLnKey = strLnKey & intNotUsed & "\"
  reg.RegWrite strLnKey & "AllowSubfolders", 1, "REG_DWORD"
  reg.RegWrite strLnKey & "Date", Now(), "REG_SZ"
  reg.RegWrite strLnKey & "Description", Application.CurrentProject.Name, "REG_SZ"
  reg.RegWrite strLnKey & "Path", strPath & "\", "REG_SZ"
 
exit_proc:
  Set reg = Nothing
  Exit Function
 
err_proc0:
  Resume checknext
 
err_proc1:
  If intNotUsed = 0 Then intNotUsed = intLocns
  Resume NextLocn

err_proc:
  MsgBox err.Description, , strTitle
  Resume exit_proc
 
End Function


Code for Windows 8 64 Bit and Access 2013 64 Bit

CODE

Public Function AddTrustedLocation()
On Error GoTo err_proc
'WARNING:  THIS CODE MODIFIES THE REGISTRY
'sets registry key for 'trusted location'

 Dim intLocns As Integer
 Dim i As Integer
 Dim intNotUsed As Integer
 Dim strLnKey As String
 Dim reg As Object
 Dim strPath As String
 Dim strTitle As String

 strTitle = "Add Trusted Location"
 Set reg = CreateObject("wscript.shell")
 strPath = CurrentProject.Path

 'Specify the registry trusted locations path for the version of Access used
 strLnKey = "HKEY_CURRENT_USER\Software\Microsoft\Office\" & Format(Application.Version, "##,##0.0") & "\Access\Security\Trusted Locations\Location"

On Error GoTo err_proc0
 'find top of range of trusted locations references in registry
 For i = 999 To 0 Step -1
     reg.RegRead strLnKey & i & "\Path"
     GoTo chckRegPths        'Reg.RegRead successful, location exists > check for path in all locations 0 - i.
checknext:
 Next
 MsgBox "Unexpected Error - No Registry Locations found", vbExclamation
 GoTo exit_proc


chckRegPths:
'Check if Currentdb path already a trusted location
'reg.RegRead fails before intlocns = i then the registry location is unused and
'will be used for new trusted location if path not already in registy

On Error GoTo err_proc1:
 For intLocns = 1 To i
     reg.RegRead strLnKey & intLocns & "\Path"
     'If Path already in registry -> exit
     If InStr(1, reg.RegRead(strLnKey & intLocns & "\Path"), strPath) = 1 Then GoTo exit_proc
NextLocn:
 Next

 If intLocns = 999 Then
     MsgBox "Location count exceeded - unable to write trusted location to registry", vbInformation, strTitle
     GoTo exit_proc
 End If
 'if no unused location found then set new location for path
 If intNotUsed = 0 Then intNotUsed = i + 1
'Prompt for Location to be added
Dim MSG1 As Integer
MSG1 = MsgBox("Add to Trusted Locations", vbYesNo, "To Open You Must Trust Location")

If MSG1 = vbYes Then
'Write Trusted Location regstry key to unused location in registry
On Error GoTo err_proc:
 strLnKey = strLnKey & intNotUsed & "\"
 reg.RegWrite strLnKey & "AllowSubfolders", 1, "REG_DWORD"
 reg.RegWrite strLnKey & "Date", Now(), "REG_SZ"
 reg.RegWrite strLnKey & "Description", Application.CurrentProject.Name, "REG_SZ"
 reg.RegWrite strLnKey & "Path", strPath & "\", "REG_SZ"

Else
MsgBox "Database can not be opened till trusted and will now close!", vbCritical
Set reg = Nothing
DoCmd.CloseDatabase
End If

exit_proc:
 Set reg = Nothing
 Exit Function

err_proc0:
 Resume checknext

err_proc1:
 If intNotUsed = 0 Then intNotUsed = intLocns
 Resume NextLocn

err_proc:
 MsgBox Err.Description, , strTitle
 Resume exit_proc

End Function

Note: In some organizations, you may need to check with your IT department about adding code which modifies registry settings automatically.

14:39, 18 May 2011 (EDT)


Creative Commons License
AddTrustedLocation by UtterAccess Wiki is licensed under a Creative Commons Attribution-ShareAlike 3.0 Unported License.
Editing and revision of the content is freely encouraged; for details, see Expected Usage.

Edit Discussion
Custom Search
Thank you for your support!
This page has been accessed 35,639 times.  This page was last modified 15:45, 23 January 2014 by Jack Leach. Contributions by Glenn Lloyd, genoma111 and Mark Davis  Disclaimers