Here's some code I had put together a while ago I just came across again.
'*******************************************************************************
' Purpose : Create a truted location
' Author : Daniel Pineault, CARDA Consultants Inc.
' Website : http://www.cardaconsultants.com
' Copyright : The following may be altered and reused as you wish so long as the
' copyright notice is left unchanged (including Author, Website and
' Copyright). It may not be sold/resold or reposted on other sites (links
' back to this site are allowed).
'
'Usage : CreateTL "winword.exe",application.CurrentProject.Path & "\Modeles\","MyProjectName",True,True
'Revision:
' 1 2010-06-23 Initial Release
' 2 2015-07-06 Modified to be used in VBA within FP
'*******************************************************************************
Function CreateTL(ByVal sAppExe As String, ByVal sPath As String, ByVal sDescription As String, _
Optional bAllowSubFolders As Boolean = -1, _
Optional bAllowNetworkLocations As Boolean = 0)
On Error GoTo Error_Handler
Const HKEY_CURRENT_USER = &H80000001
Dim oRegistry
' Dim sPath 'Path to set as a Trusted Location
' Dim sDescription 'Description of the Trusted Location
' Dim bAllowSubFolders 'Enable subFolders as Trusted Locations
' Dim bAllowNetworkLocations As Boolean 'Enable Network Locations as Trusted Locations
Dim sApp As String
Dim sAppVer As String
Dim bAlreadyExists As Boolean
Dim sParentKey As String
Dim iLocCounter As Integer
Dim arrChildKeys
Dim sChildKey
Dim sValue As String
Dim sNewKey As String
'Determine the location/path of the user's MyDocuments folder
'*******************************************************************************
Set oRegistry = GetObject("winmgmts:\\.\root\default:StdRegProv")
' sPath = "TheFullPathOfYourTrustedLocation" 'ie: c:\databases\
' sDescription = "YourTrustedLocationDescriptionGoesHere"
' bAllowSubFolders = True
bAlreadyExists = 0
'Determine the current verion of the App
sAppVer = GetAppVersion(sAppExe) ' Returns: 12.0.6720.5000
sAppVer = ExtractNthTerm(sAppVer, ".", 1) & "." & ExtractNthTerm(sAppVer, ".", 2)
'Build the corresponding RegKeyPath
Select Case sAppExe
Case "msaccess.exe"
sApp = "Access"
Case "winword.exe"
sApp = "Word"
Case "excel.exe"
sApp = "Excel"
End Select
sParentKey = "Software\Microsoft\Office\" & sAppVer & "\" & sApp & "\Security\Trusted Locations"
' sParentKey = "Software\Microsoft\Office\12.0\Access\Security\Trusted Locations"
' sParentKey = "Software\Microsoft\Office\12.0\Excel\Security\Trusted Locations"
' sParentKey = "Software\Microsoft\Office\12.0\PowerPoint\Security\Trusted Locations"
' sParentKey = "Software\Microsoft\Office\12.0\Word\Security\Trusted Locations"
iLocCounter = 0
oRegistry.EnumKey HKEY_CURRENT_USER, sParentKey, arrChildKeys
For Each sChildKey In arrChildKeys
oRegistry.GetStringValue HKEY_CURRENT_USER, sParentKey & "\" & sChildKey, "Description", sValue
If sValue = sDescription Then bAlreadyExists = True
If CInt(Mid(sChildKey, 9)) > iLocCounter Then
iLocCounter = CInt(Mid(sChildKey, 9))
End If
Next
'Uncomment the following 4 linesif your wish to enable network locations as Trusted
' Locations
' bAllowNetworkLocations = True
If bAllowNetworkLocations = -1 Then
oRegistry.SetDWORDValue HKEY_CURRENT_USER, sParentKey, "AllowNetworkLocations", 1
End If
If bAlreadyExists = 0 Then
sNewKey = sParentKey & "\Location" & CStr(iLocCounter + 1)
oRegistry.CreateKey HKEY_CURRENT_USER, sNewKey
oRegistry.SetStringValue HKEY_CURRENT_USER, sNewKey, "Path", sPath
oRegistry.SetStringValue HKEY_CURRENT_USER, sNewKey, "Description", sDescription
If bAllowSubFolders = -1 Then
oRegistry.SetDWORDValue HKEY_CURRENT_USER, sNewKey, "AllowSubFolders", 1
End If
End If
Error_Handler_Exit:
On Error Resume Next
Set oRegistry = Nothing
Exit Function
Error_Handler:
LogError Err.Number, Err.Description, sModName & "/CreateTL", , True
Resume Error_Handler_Exit
End Function
'GetAppVersion("winword.exe")
' Returns: 12.0.6720.5000
Function GetAppVersion(sAppExe As String) As String
On Error GoTo Error_Handler
Const HKEY_LOCAL_MACHINE = &H80000002
Dim oRegistry
Dim oFSO
Dim sKey
' Dim sAppExe
Dim sValue
' Dim sAppVersion
Set oRegistry = GetObject("winmgmts:{impersonationLevel=impersonate}//./root/default:StdRegProv")
Set oFSO = CreateObject("Scripting.FileSystemObject")
sKey = "Software\Microsoft\Windows\CurrentVersion\App Paths"
'sAppExe = "excel.exe"
'sAppExe = "GROOVE.exe"
'sAppExe = "infopath.exe"
' sAppExe = "MSACCESS.EXE"
'sAppExe = "MSPUB.EXE"
'sAppExe = "OneNote.exe"
'sAppExe = "OUTLOOK.EXE"
'sAppExe = "winword.exe"
'sAppExe = "firefox.exe" 'Even works with a number of other programs!
oRegistry.GetStringValue HKEY_LOCAL_MACHINE, sKey & "\" & sAppExe, "", sValue
GetAppVersion = oFSO.GetFileVersion(sValue)
Error_Handler_Exit:
On Error Resume Next
Set oFSO = Nothing
Set oRegistry = Nothing
Exit Function
Error_Handler:
LogError Err.Number, Err.Description, sModName & "/GetAppVersion", , True
Resume Error_Handler_Exit
End Function
One precision, in my code, and a lot of other code you'll see us creating TL with sequential names
- Location0
- Location1
- Location2
- and so on
we are merely following what MS uses, but in reality, you can name it as you like and make it more meaningful!
Daniel Pineault, 2010-2016 Microsoft MVP
Professional Support: http://www.cardaconsultants.com
MS Access Tips and Code Samples: http://www.devhut.net
