1

我的目标是生成包含要针对给定变量集评估的代码的字符串。我在这些问题中发现了一些类似的努力：

  1. VBA在字符串中执行代码
  2. 如何将字符串评估为 VBA 中的对象？

因为在上面 (2) 中提供的代码中ScriptControl，x64 存在问题，所以我在以下位置找到了一些补丁：

  1. 让 ScriptControl 与 Excel 2010 x64 一起工作

不幸的是，由于某些 Windows 补丁，导致无法发布 GUID，因此存在更多问题。sSignature = Left(CreateObject("Scriptlet.TypeLib").GUID, 38)由于缺乏权限，这阻止了返回正确的 GUID。

这在以下帖子中得到了强调：

  1. MS Access VBA 错误：运行时错误“70”权限被拒绝
  2. VBA 'set typelib = createobject("scriptlet.typelib")' 权限被拒绝

根据参考资料 (5)，我添加了一些代码来生成 GUID。

不幸的是，此代码仍然无法正常工作，我在执行时收到错误代码 #13，“类型不匹配”：oShellWnd.GetProperty(sSignature)。

注意：我认为应该更改 cMSHTAx86Host 的代码以避免无限循环（可能只允许一定次数的重试，并且可能会在两者之间短暂暂停，以避免无限循环并占用处理器）。

我非常想要一些帮助，并发布在我在下面使用的代码下方。

  1. A 类 cMSHTAx86Host (cMSHTAx86Host.cls)
VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "cMSHTAx86Host"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True

Option Explicit
#If VBA7 Then
    Private Declare PtrSafe Function CoCreateGuid Lib "ole32" (ByRef GUID As Byte) As LongPtr
#Else
    Declare Function CoCreateGuid Lib "ole32" (ByRef GUID As Byte) As Long
#End If

Private oWnd As Object

Private Sub Class_Initialize()
    
    #If Win64 Then
        Set oWnd = CreateWindow()
        oWnd.execScript "Function CreateObjectx86(sProgID): Set CreateObjectx86 = CreateObject(sProgID) End Function", "VBScript"
    #End If
    
End Sub

Private Function CreateWindow()
    
    ' source http://forum.script-coding.com/viewtopic.php?pid=75356#p75356
    Dim sSignature, oShellWnd, oProc
    
    On Error Resume Next
    'Bug due to security patch see:
    ' https://stackoverflow.com/questions/45332357/ms-access-vba-error-run-time-error-70-permission-denied
    ' https://stackoverflow.com/questions/45082258/vba-set-typelib-createobjectscriptlet-typelib-permission-denied
    'sSignature = Left(CreateObject("Scriptlet.TypeLib").GUID, 38)
    sSignature = Left(GenerateGUID, 38)
    CreateObject("WScript.Shell").Run "%systemroot%\syswow64\mshta.exe        'x86Host'</script><hta:application showintaskbar=no /><object id='shell' classid='clsid:8856F961-340A-11D0-A96B-00C04FD705A2'><param name=RegisterAsBrowser value=1></object><script>shell.putproperty('" & sSignature & "',document.parentWindow);</script></head>""", 0, False
    Do
        For Each oShellWnd In CreateObject("Shell.Application").Windows
            Set CreateWindow = oShellWnd.GetProperty(sSignature)
            If Err.Number = 0 Then Exit Function
            Err.Clear
        Next
        'TODO: need to include code here to sleep and avoid infinite loops
    Loop
    
End Function

Function CreateObjectx86(sProgID)
    
    #If Win64 Then
        If InStr(TypeName(oWnd), "HTMLWindow") = 0 Then Class_Initialize
        Set CreateObjectx86 = oWnd.CreateObjectx86(sProgID)
    #Else
        Set CreateObjectx86 = CreateObject(sProgID)
    #End If
    
End Function

Function Quit()
    
    #If Win64 Then
        If InStr(TypeName(oWnd), "HTMLWindow") > 0 Then oWnd.Close
    #End If
    
End Function

Private Sub Class_Terminate()
    
    Quit
    
End Sub


Private Function GenerateGUID() As String
    Dim ID(0 To 15) As Byte
    Dim N As Long
    Dim GUID As String
    Dim Res As Long
    Res = CLng(CoCreateGuid(ID(0)))

    For N = 0 To 15
        GUID = GUID & IIf(ID(N) < 16, "0", "") & Hex$(ID(N))
        If Len(GUID) = 8 Or Len(GUID) = 13 Or Len(GUID) = 18 Or Len(GUID) = 23 Then
            GUID = GUID & "-"
        End If
    Next N
    GenerateGUID = GUID
End Function

Public Function eval(strEvalContent As String) As Object
    With CreateObjectx86("ScriptControl")
        .Language = "VBScript"
        .AddObject "app", Application, True
        Set eval = .eval(strEvalContent)
    End With
End Function
  1. 如下所示的一个模块（注意我不确定如何在运行 oHost.eval 时传入可用的变量）
Sub testEvalCode()
    Dim strEvalContent As String
    Dim oHost As New cMSHTAx86Host
    
    Dim oResult As Object
    someText = "Value"
    strEvalContent = "someText & "" - added"""
    Set oResult = oHost.eval(strEvalContent) 'unsure how to pass all variable available for the evaluation
    MsgBox CStr(objQueryTable) 'NOTE, I am yet unsure how the oResult will look like
End Sub
4

0 回答 0