Solved

Change Trust Centre settings MS Access 2007 with vbScript

Posted on 2010-09-18
11
747 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)
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 84

Accepted Solution

by:
Scott McDaniel (Microsoft Access MVP - EE MVE ) earned 250 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 84
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
 

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
Ransomware-A Revenue Bonanza for Service Providers

Ransomware – malware that gets on your customers’ computers, encrypts their data, and extorts a hefty ransom for the decryption keys – is a surging new threat.  The purpose of this eBook is to educate the reader about ransomware attacks.

 
LVL 47

Assisted Solution

by:Dale Fye (Access MVP)
Dale Fye (Access MVP) earned 250 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 84
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 47

Expert Comment

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

Featured Post

Comprehensive Backup Solutions for Microsoft

Acronis protects the complete Microsoft technology stack: Windows Server, Windows PC, laptop and Surface data; Microsoft business applications; Microsoft Hyper-V; Azure VMs; Microsoft Windows Server 2016; Microsoft Exchange 2016 and SQL Server 2016.

Question has a verified solution.

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

I originally created this report in Crystal Reports 2008 where there is an option to underlay sections. I initially came across the problem in Access Reports where I was unable to run my border lines down through the entire page as I was using the P…
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…
In Microsoft Access, learn how to “cascade” or have the displayed data of one combo control depend upon what’s entered in another. Base the dependent combo on a query for its row source: Add a reference to the first combo on the form as criteria i…
Access reports are powerful and flexible. Learn how to create a query and then a grouped report using the wizard. Modify the report design after the wizard is done to make it look better. There will be another video to explain how to put the final p…

864 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

19 Experts available now in Live!

Get 1:1 Help Now