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. クラス 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