如果“工具”菜单中没有出现“数字签名”项，如何将证书添加到 VBA Access 项目？

Posted 2023-05-06

【中文标题】如果“工具”菜单中没有出现“数字签名”项，如何将证书添加到 VBA Access 项目？

【英文标题】：How can I add a certificate to VBA Access project if the Digital Signature item doesn't appear in the Tools menu?

【发布时间】：2013-07-01 16:20:29

【问题描述】：

我正在尝试让 Access 2000 数据库在 Access 2010 运行时中运行，并删除有关文件不受信任的警告对话框。我做了一些研究，发现了 SelfCert.exe 程序。 This is a good tutorial on certificates. And this, too. 甚至微软也有关于 Access 2000 的说明，表明该菜​​单项应该存在。但是，Access 2000 VBA IDE 中的工具菜单没有数字签名菜单项。更糟糕的是，当我右键单击菜单栏以自定义工具菜单时，我确实在自定义列表中看到了 Digital Signature... 项。当我单击并拖动以将其添加到“工具”菜单时，它会忽略我的命令。多么固执！如果我单击并将其他任何内容拖动到“工具”菜单，它就像一个魅力。什么？！

如何安装该菜单项？或者，更好的是，如何让我的数据库在从 Access 2010 运行时打开时不出现安全警告？

【参考方案1】：

经过一些更重要的研究，我找到了第二个问题的答案，而这最终正是我想要的答案。在 Access 2010 运行时打开 Access 2000 数据库时，如何消除潜在的安全问题对话框？

基本上，您需要将数据库添加到受信任位置列表中。 Access 2010 运行时不提供此功能的 UI，因此您必须以编程方式进行。本站提供代码：Utter Access Add Trusted Location

我针对这种情况下的具体要求进行了修改。在 Access 2010 运行时运行 Access 2000 数据库。您将需要根据注册表设置为其他版本的运行时修改它。另外，我读到这在 Windows 8 中不起作用。但我还发现您不需要管理权限来运行此代码，因为它只修改了注册表中的 HKEY_CURRENT_USER 配置单元，当前用户具有完全访问权限。

Public Function AddTrustedLocation()
On Error GoTo err_proc
'WARNING:  THIS CODE MODIFIES THE REGISTRY
'You do not need administrator privileges
'since it only affects the HK_CURRENT_USER hive
'sets registry key for 'trusted location'

Dim intLocns As Integer
Dim i As Integer
Dim intNotUsed As Integer
Dim strLnKey As String
Dim reg As Object
Dim strPath As String
Dim strTitle As String

strTitle = "Add Trusted Location"
Set reg = CreateObject("wscript.shell")
strPath = CurrentProject.path

'Specify the registry trusted locations path for the Access 2010 runtime
strLnKey = "HKEY_CURRENT_USER\Software\Microsoft\Office\14.0\Access\Security\Trusted Locations\Location"

On Error GoTo err_proc0
'find top of range of trusted locations references in registry
For i = 999 To 0 Step -1
    reg.RegRead strLnKey & i & "\Path"
    GoTo chckRegPths        'Reg.RegRead successful, location exists > check for path in all locations 0 - i.
checknext:
Next
MsgBox "Unexpected Error - No Registry Locations found", vbExclamation
    GoTo exit_proc

chckRegPths:
    'Check if Currentdb path already a trusted location
    'reg.RegRead fails before intlocns = i then the registry location is unused and
    'will be used for new trusted location if path not already in registy

    On Error GoTo err_proc1:
    For intLocns = 1 To i
        reg.RegRead strLnKey & intLocns & "\Path"
        'If Path already in registry -> exit
        If InStr(1, reg.RegRead(strLnKey & intLocns & "\Path"), strPath) = 1 Then GoTo exit_proc
NextLocn:
    Next

    If intLocns = 999 Then
        MsgBox "Location count exceeded - unable to write trusted location to registry", vbInformation, strTitle
        GoTo exit_proc
    End If
    'if no unused location found then set new location for path
    If intNotUsed = 0 Then intNotUsed = i + 1

    'Write Trusted Location regstry key to unused location in registry
    On Error GoTo err_proc:
    strLnKey = strLnKey & intNotUsed & "\"
    reg.RegWrite strLnKey & "AllowSubfolders", 1, "REG_DWORD"
    reg.RegWrite strLnKey & "Date", Now(), "REG_SZ"
    reg.RegWrite strLnKey & "Description", Application.CurrentProject.Name, "REG_SZ"
    reg.RegWrite strLnKey & "Path", strPath & "\", "REG_SZ"

exit_proc:
      Set reg = Nothing
      Exit Function

err_proc0:
      Resume checknext

err_proc1:
      If intNotUsed = 0 Then intNotUsed = intLocns
      Resume NextLocn

err_proc:
      MsgBox Err.Description, , strTitle
      Resume exit_proc

End Function

我将此函数添加到 AutoExec 宏中。当用户第一次登录时，他们确实会收到安全通知；但是，只要文档保留在它首次运行的受信任位置，它就永远不会再次出现。呜呜！

【讨论】：

这是一个很棒的功能！！但是，仅当数据库仅本地存储在您的计算机上时，它才有效。如果它位于映射驱动器或服务器上，则添加 keyu，但访问不会将其识别为受信任的位置。

@Blenikos 您应该将数据库拆分为前端和后端。前端存储在本地计算机上。后端存储在映射或服务器上。

我已经做到了。我不知道它实际上会起作用。我认为创建与 be 的连接会使弹出窗口再次出现！！非常感谢！

【参考方案2】：

这里接受的答案是我正在寻找的，但提供的代码太远了，所以我重写了大部分。如果您来这里寻找代码，请查看我的解决方案。它可以动态地与任何版本的 Access 一起使用。它允许网络位置。主子接受变量，以便您可以信任任何给定的位置。有一个TrustCurrentProject sub 可以满足@Bobort 的要求。

Option Compare Database
Option Explicit
'
' TrustIssues by HackSlash 2019-01-21
'   Use this module to trust Access paths
'   Removes those annoying security pop-ups
'
Const HKEY_CLASSES_ROOT = &H80000000
Const HKEY_CURRENT_USER = &H80000001
Const HKEY_LOCAL_MACHINE = &H80000002
Const HKEY_USERS = &H80000003

Const REG_SZ = 1
Const REG_EXPAND_SZ = 2
Const REG_BINARY = 3
Const REG_DWORD = 4
Const REG_MULTI_SZ = 7

' Returns a collection of sub-keys from the given hive\key passed in
Public Function EnumerateKeys(ByVal hive As Variant, ByVal key As String) As Collection
    Set EnumerateKeys = New Collection

    Dim reg As Object
    Set reg = GetObject("winmgmts://./root/default:StdRegProv")
    Dim allSubKeys As Variant
    reg.EnumKey hive, key, allSubKeys
    If Not IsNull(allSubKeys) Then
        Dim subkey As Variant
        For Each subkey In allSubKeys
            EnumerateKeys.Add subkey
        Next
    End If
End Function

' Adds registry key for  new trusted location.
Public Sub AddTrustedLocation(ByVal locName As String, ByVal trustPath As String, ByVal descript As String)
    ' WARNING:  THIS CODE MODIFIES THE REGISTRY
    ' You do not need administrator privileges since it only affects HKEY_CURRENT_USER

    On Error GoTo err_proc

    ' Get version of Access that is running now
    Dim version As String
    version = Application.SysCmd(acSysCmdAccessVer)

    ' Specify the registry trusted locations path for the Access runtime based on the detected version
    Dim regKeyPath As String
    regKeyPath = "Software\Microsoft\Office\" & version & "\Access\Security\Trusted Locations"

    ' Collect all the currently trusted locations
    Dim trustedLocations As Collection
    Set trustedLocations = EnumerateKeys(HKEY_CURRENT_USER, regKeyPath)

    Dim registry As Object
    Set registry = GetObject("winmgmts://./root/default:StdRegProv")

    ' Turn on "Allow Netowrk Locations"
    registry.SetDWORDValue HKEY_CURRENT_USER, regKeyPath, "AllowNetworkLocations", 1

    ' Check if the path is already a trusted location
    Dim locKey As Variant
    For Each locKey In trustedLocations
        If locKey = locName Then Exit Sub

        On Error Resume Next
        Dim thePath As String
        Debug.Print registry.GetStringValue(HKEY_CURRENT_USER, regKeyPath & "\" & locKey, "Path", thePath)

        If thePath = trustPath Then Exit Sub
    Next locKey

    On Error GoTo err_proc
    ' Write Trusted Location regstry key to specified location
    regKeyPath = regKeyPath & "\" & locName
    Debug.Print registry.CreateKey(HKEY_CURRENT_USER, regKeyPath)
    Debug.Print registry.SetDWORDValue(HKEY_CURRENT_USER, regKeyPath, "AllowSubfolders", 1)
    Debug.Print registry.SetStringValue(HKEY_CURRENT_USER, regKeyPath, "Date", CStr(Date))
    Debug.Print registry.SetStringValue(HKEY_CURRENT_USER, regKeyPath, "Description", descript)
    Debug.Print registry.SetStringValue(HKEY_CURRENT_USER, regKeyPath, "Path", trustPath)         

err_proc:
    If Err.Number <> 0 Then MsgBox Err.Description, , "ERROR while trusting this project"

End Sub

Public Sub TrustCurrentProject()
    AddTrustedLocation Replace(CurrentProject.Name, " ", vbNullString), CurrentProject.Path, CurrentProject.Name
End Sub

【参考方案3】：

Access 2000 不支持此功能，此功能仅在 Access 2003 中添加。

【讨论】：

因为 Word/Excel/PowerPoint 2000 支持它。 VBA 允许主机显示/隐藏此选项，我猜这是他们实现此方式的效果。