在 VBA 中创建动态表单，而不选择“信任对 VBA 项目对象模型的访问”

Question

我正在做一个项目，我正在Excel中创建一个统计工具，该工具应该供其他人使用，但出于安全原因，他们不会接受选择了该选项的项目。因为他们很容易受到恶意软件和其他东西的影响。

那么，当未选择该选项时，有没有办法仍然创建带有标签、组合框和按钮的动态表单？

据我所知，出现问题的部分是：

Set newForm = ThisWorkbook.VBProject.VBComponents.Add(vbext_ct_MSForm)

Set newLabel = newForm.Designer.Controls.Add("Forms.Label.1")
    With newLabel
        .Caption = nameCell.value
        .Left = 10
        .Top = topPosition
        .Width = 100
        .Height = 20
    End With

Set newButton = newForm.Designer.Controls.Add("Forms.CommandButton.1")
With newButton
    .Caption = "OK"
    .Left = 10
    .Top = topPosition
    .Width = 100
    .Height = 30
End With

ThisWorkbook.VBProject.VBComponents.Remove vbComp

我认为这些都是 VBA 的东西被改变的地方。但这并不重要，因为我正在寻找整体修复

Answer 1

为了完成您需要的操作，请使用下一个代码并在测试后发送一些反馈：

Sub TrustAccessToVBAProj() .
    Dim wshShell As Object, strKeyPath As String, exVers As String

    exVers = GetExVers("Excel.Exe")
    Set wshShell = CreateObject("WScript.Shell")
    strKeyPath = "HKCU\Software\Microsoft\Office\" & exVers & "\Excel\Security\AccessVBOM"
    Debug.Print wshShell.RegRead(strKeyPath): Stop
    If wshShell.RegRead(strKeyPath) = 0 Then
        wshShell.RegWrite strKeyPath, "1", "REG_DWORD"
    End If
End Sub

Function GetExVers(ExcelVer As String) As String 'extract Excel Version (like 16.0)
   Dim ExcelVers As String, exVers As String
   ExcelVers = GetAppVersion(ExcelVer)
   GetExVers = Format(Split(ExcelVers, ".")(0), "##.0")
End Function

Private Function GetAppVersion(sAppExe As String) As String 'extract application version
    Const HKEY_LOCAL_MACHINE = &H80000002
    Dim oRegistry As Object, oFSO As Object, sKey As String, sValue As String

    Set oRegistry = GetObject("winmgmts:{impersonationLevel=impersonate}//./root/default:StdRegProv")
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    sKey = "Software\Microsoft\Windows\CurrentVersion\App Paths"

    oRegistry.GetStringValue HKEY_LOCAL_MACHINE, sKey & "\" & sAppExe, "", sValue
    GetAppVersion = oFSO.GetFileVersion(sValue)

    Set oFSO = Nothing: Set oRegistry = Nothing
End Function