?
Solved

Change Trust Centre settings MS Access 2007 with vbScript

Posted on 2010-09-18
11
Medium Priority
?
778 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
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 4
  • 4
  • 3
11 Comments
 
LVL 48

Expert Comment

by:Dale Fye
ID: 33711129
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 85

Accepted Solution

by:
Scott McDaniel (Microsoft Access MVP - EE MVE ) earned 1000 total points
ID: 33711165
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 85
ID: 33711169
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
How Blockchain Is Impacting Every Industry

Blockchain expert Alex Tapscott talks to Acronis VP Frank Jablonski about this revolutionary technology and how it's making inroads into other industries and facets of everyday life.

 

Author Comment

by:djk001
ID: 33712375
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
ID: 33712407
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
 
LVL 48

Assisted Solution

by:Dale Fye
Dale Fye earned 1000 total points
ID: 33712426
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
ID: 33712611
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 85
ID: 33712897
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 48

Expert Comment

by:Dale Fye
ID: 33712923
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
ID: 33713502
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 85
ID: 33715257
Good idea (putting it in writing).
0

Featured Post

Free Tool: Port Scanner

Check which ports are open to the outside world. Helps make sure that your firewall rules are working as intended.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Did you know that more than 4 billion data records have been recorded as lost or stolen since 2013? It was a staggering number brought to our attention during last week’s ManageEngine webinar, where attendees received a comprehensive look at the ma…
Code that checks the QuickBooks schema table for non-updateable fields and then disables those controls on a form so users don't try to update them.
Learn how to number pages in an Access report over each group. Activate two pass printing by referencing the pages property: Add code to the Page Footers OnFormat event to capture the pages as there occur for each group. Use the pages property to …
In Microsoft Access, when working with VBA, learn some techniques for writing readable and easily maintained code.

800 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