Go Premium for a chance to win a PS4. Enter to Win

x
  • Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 781
  • Last Modified:

Change Trust Centre settings MS Access 2007 with vbScript

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
djk001
Asked:
djk001
  • 4
  • 4
  • 3
2 Solutions
 
Dale FyeCommented:
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
 
Scott McDaniel (Microsoft Access MVP - EE MVE )Infotrakker SoftwareCommented:
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
 
Scott McDaniel (Microsoft Access MVP - EE MVE )Infotrakker SoftwareCommented:
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
VIDEO: THE CONCERTO CLOUD FOR HEALTHCARE

Modern healthcare requires a modern cloud. View this brief video to understand how the Concerto Cloud for Healthcare can help your organization.

 
djk001Author Commented:
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
 
djk001Author Commented:
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
 
Dale FyeCommented:
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
 
djk001Author Commented:
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
 
Scott McDaniel (Microsoft Access MVP - EE MVE )Infotrakker SoftwareCommented:
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
 
Dale FyeCommented:
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
 
djk001Author Commented:
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
 
Scott McDaniel (Microsoft Access MVP - EE MVE )Infotrakker SoftwareCommented:
Good idea (putting it in writing).
0

Featured Post

Independent Software Vendors: We Want Your Opinion

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

  • 4
  • 4
  • 3
Tackle projects and never again get stuck behind a technical roadblock.
Join Now