Solved

Change Trust Centre settings MS Access 2007 with vbScript

Posted on 2010-09-18
11
735 Views
Last Modified: 2012-06-27
I found this code in EE after 3 days for searching for something like it on the internet.  It works perfectly except I want to make a small change to it.
Before it finishes searching for the next intHighest, I want it to read the Path and check for the existance of strFolder.

If strFolder exists in any of the Paths, I want the scrpt to cease.  If the folder does not exist in any of the Paths, I want the script to continue and CreateKey and SetStringValue for the Path and to SetStringValue for the Description.

Can anyone help without totally altering the vbScript, but by adding the above requirement?


Const HKEY_CLASSES_ROOT = &H80000000
Const HKEY_CURRENT_USER = &H80000001
Const HKEY_LOCAL_MACHINE = &H80000002
Const HKEY_USERS = &H80000003
Const HKEY_CURRENT_CONFIG = &H80000005
 
strProgram = "Access"
strFolder = "D:\Data\DJK"
strDescription = "ATLAS Trusted Location"
blnAllowSubFolders = True
 
strParentKey = "Software\Microsoft\Office\12.0\" & strProgram & "\Security\Trusted Locations"
intHighest = 0
 
Set objRegistry = GetObject("winmgmts:\\.\root\default:StdRegProv")
 
objRegistry.EnumKey HKEY_CURRENT_USER, strParentKey, arrChildKeys
 
For Each strChildKey in arrChildKeys
    If CInt(Mid(strChildKey, 9)) > intHighest Then
        intHighest = CInt(Mid(strChildKey, 9))
    End If
Next
 
strNewKey = strParentKey & "\Location" & CStr(intHighest + 1)
 
objRegistry.CreateKey HKEY_CURRENT_USER, strNewKey
objRegistry.SetStringValue HKEY_CURRENT_USER, strNewKey, "Path", strFolder
objRegistry.SetStringValue HKEY_CURRENT_USER, strNewKey, "Description", strDescription
 
If blnAllowSubFolders Then
    objRegistry.SetDWORDValue HKEY_CURRENT_USER, strNewKey, "AllowSubFolders", 1
End If

0
Comment
Question by:djk001
  • 4
  • 4
  • 3
11 Comments
 
LVL 47

Expert Comment

by:Dale Fye (Access MVP)
Comment Utility
Use the Dir() function with syntax:

If LEN(Dir(strFolder & "\", vbDirectory)) > 0 then

The Dir function will return a period (".") if the folder exists, and an empty string if the folder doesn't exist.
0
 
LVL 84

Accepted Solution

by:
Scott McDaniel (Microsoft Access MVP - EE MVE ) earned 250 total points
Comment Utility
The below changes will let you know if that path exists. I'd just issued a MsgBox, but you can do what you need once you determine the Path exists (exit the process, alert the user, etc etc). At this point, the code simply continues on and adds the location again, which is probably not what you want to do.
Dim sPath As String

 

strProgram = "Access"

strFolder = "D:\Data\DJK"

strDescription = "ATLAS Trusted Location"

blnAllowSubFolders = True

 

strParentKey = "Software\Microsoft\Office\12.0\" & strProgram & "\Security\Trusted Locations"

intHighest = 0

 

Set objRegistry = GetObject("winmgmts:\\.\root\default:StdRegProv")

 

objRegistry.EnumKey HKEY_CURRENT_USER, strParentKey, arrChildKeys

 

For Each strChildKey In arrChildKeys

  **** objRegistry.getstringvalue HKEY_CURRENT_USER, strParentKey & "\" & strChildKey, "Path", sPath

  **** If sPath = strFolder Then MsgBox "Found path" ' Debug.Print sPath

    If CInt(Mid(strChildKey, 9)) > intHighest Then

        intHighest = CInt(Mid(strChildKey, 9))

    End If

Next

 

strNewKey = strParentKey & "\Location" & CStr(intHighest + 1)

 

objRegistry.CreateKey HKEY_CURRENT_USER, strNewKey

objRegistry.SetStringValue HKEY_CURRENT_USER, strNewKey, "Path", strFolder

objRegistry.SetStringValue HKEY_CURRENT_USER, strNewKey, "Description", strDescription

 

If blnAllowSubFolders Then

    objRegistry.SetDWORDValue HKEY_CURRENT_USER, strNewKey, "AllowSubFolders", 1

End If

Open in new window

0
 
LVL 84
Comment Utility
Note also that you'll have to remove the "****" from the code in order for it to run. I included those so you could see the changes I made.
0
 

Author Comment

by:djk001
Comment Utility
Hello and thank you LSMConsulting

I tried the script and it failed on line 1, character 11.    "Dim sPath As String"
I took the "As String" away and it then failed on line 15, character 1 with the Error being "Object not a collection"
Unfortunately I don't know enough about vbScript to debug the additions you have made and therefore need your further input on this.

Furthermore, you stated "... I'd just issued a MsgBox, but you can do what you need once you determine the Path exists (exit the process, alert the user, etc etc)....."

What would the appropriate syntax to tell the script to 'exit the process'?

Your help is most appreciated.

0
 

Author Comment

by:djk001
Comment Utility
Hello fyed

It is the value of strFolder that I need to establish existence.

The strParentKey:
strParentKey = "Software\Microsoft\Office\12.0\" & strProgram & "\Security\Trusted Locations"

Under this there could be a number of Locations i.e.
Location0
Location1
Location2   etc...

and in each Location there with be a Path.  It is the 'Path' that I need to check for the existence of strFolder.

Unfortunately I am not comfortably familiar enough with vbScript to know what to do with your suggestion, therefore I need my hand held here.

Any further assistance you can provide will be greatly appreciated.
0
6 Surprising Benefits of Threat Intelligence

All sorts of threat intelligence is available on the web. Intelligence you can learn from, and use to anticipate and prepare for future attacks.

 
LVL 47

Assisted Solution

by:Dale Fye (Access MVP)
Dale Fye (Access MVP) earned 250 total points
Comment Utility
Try:

if Len(Dir(strFolder, vbDirectory)) > 0 Then
    objRegistry.CreateKey HKEY_CURRENT_USER, strNewKey
    objRegistry.SetStringValue HKEY_CURRENT_USER, strNewKey, "Path", strFolder
    objRegistry.SetStringValue HKEY_CURRENT_USER, strNewKey, "Description", strDescription
 
    If blnAllowSubFolders Then
        objRegistry.SetDWORDValue HKEY_CURRENT_USER, strNewKey, "AllowSubFolders", 1
    End If
End If

This should check to see whether strFolder exists as a folder, and if so, creates your new addition to the trusted locations list.  I'm not much on vbScript, but this should work in Office VBA.
0
 

Author Comment

by:djk001
Comment Utility
Hi fyed

Where abouts in the body of the existing script would I put this new bit of code?  And is it testing the Path for the actual value of strFolder?

0
 
LVL 84
Comment Utility
You have to incorporate that code into your own routines. Here's the whole routine that I tested, which works on my machine.

<What would the appropriate syntax to tell the script to 'exit the process'?>

You'd use "Exit Function ":

If sPath = strFolder Then Exit Function

You would replace the other line that starts with "If sPath" with the line above.

I'd also highly caution you about mucking around in the registry if you are not very well versed in the inner workings. Changes to the registry can wreak havoc on the machine, so be very, very careful about using code you find on the 'net unless you fully understand what is going on. I daresay that someone who is not "well versed in vbscript" should probably consider doing this manually instead of through code.

Function CheckReg()



Const HKEY_CLASSES_ROOT = &H80000000

Const HKEY_CURRENT_USER = &H80000001

Const HKEY_LOCAL_MACHINE = &H80000002

Const HKEY_USERS = &H80000003

Const HKEY_CURRENT_CONFIG = &H80000005

 

Dim strProgram As String

Dim strFolder As String

Dim strDescription As String

Dim blnAllowSubFolders As Boolean

Dim strParentKey As String

Dim intHighest As Integer

Dim objRegistry As Variant

Dim arrChildKeys As Variant

Dim strChildKey As Variant

Dim strNewKey As String

Dim sPath As String

 

strProgram = "Access"

strFolder = "D:\Data\DJK"

strDescription = "ATLAS Trusted Location"

blnAllowSubFolders = True

 

strParentKey = "Software\Microsoft\Office\12.0\" & strProgram & "\Security\Trusted Locations"

intHighest = 0

 

Set objRegistry = GetObject("winmgmts:\\.\root\default:StdRegProv")

 

objRegistry.EnumKey HKEY_CURRENT_USER, strParentKey, arrChildKeys

 

For Each strChildKey In arrChildKeys

  objRegistry.getstringvalue HKEY_CURRENT_USER, strParentKey & "\" & strChildKey, "Path", sPath

  If sPath = strFolder Then MsgBox "Found path" ' Debug.Print sPath

    If CInt(Mid(strChildKey, 9)) > intHighest Then

        intHighest = CInt(Mid(strChildKey, 9))

    End If

Next

 

strNewKey = strParentKey & "\Location" & CStr(intHighest + 1)

 

objRegistry.CreateKey HKEY_CURRENT_USER, strNewKey

objRegistry.SetStringValue HKEY_CURRENT_USER, strNewKey, "Path", strFolder

objRegistry.SetStringValue HKEY_CURRENT_USER, strNewKey, "Description", strDescription

 

If blnAllowSubFolders Then

    objRegistry.SetDWORDValue HKEY_CURRENT_USER, strNewKey, "AllowSubFolders", 1

End If



End Function

Open in new window

0
 
LVL 47

Expert Comment

by:Dale Fye (Access MVP)
Comment Utility
You already had most of that code, all I did was add the If statement and the End If statement.

I would echo Scott's comments about messing with the registry.
0
 

Author Comment

by:djk001
Comment Utility
LSMConsulting you are right, one who is not familiar with the registry should not be playing with it.  I don't feel comfortable with what I am being asked to do.  However, I am expected to do it.  
Making these changes manuall is NOT an option with the number of users of this database.

However, the focus has changed and the company now wants the Macro settings to be disabled.

I don't know whether you or 'fyed' have given me the correct answers so I am just going to assume they are both right, close the question, allot points to you both, and post another question regarding  changing 'HKEY_CURRENT_USER\Software\Microsoft\Office\12\Access\Security\VBAWarnings' to a value of 1.

I'm not comfortable with working in the registry but it is being expected of me.  I have voiced me concerns verbally and in writing, explaining the consequences and the ramifications of a novice performing such tasks, but to no avail.  The saving grace is that I have put it in writing.

Thank you both for your help.
0
 
LVL 84
Comment Utility
Good idea (putting it in writing).
0

Featured Post

How your wiki can always stay up-to-date

Quip doubles as a “living” wiki and a project management tool that evolves with your organization. As you finish projects in Quip, the work remains, easily accessible to all team members, new and old.
- Increase transparency
- Onboard new hires faster
- Access from mobile/offline

Join & Write a Comment

Overview: This article:       (a) explains one principle method to cross-reference invoice items in Quickbooks®       (b) explores the reasons one might need to cross-reference invoice items       (c) provides a sample process for creating a M…
Describes a method of obtaining an object variable to an already running instance of Microsoft Access so that it can be controlled via automation.
Using Microsoft Access, learn some simple rules for how to construct tables in a relational database. Split up all multi-value fields into single values: Split up fields that belong to other things into separate tables: Make sure that all record…
What’s inside an Access Desktop Database. Will look at the basic interface, Navigation Pane (Database Container), Tables, Queries, Forms, Report, Macro’s, and VBA code.

744 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

17 Experts available now in Live!

Get 1:1 Help Now