以下は訳あって削除済みの過去記事の転載です(published at 2023-08-23 21:16)。
こんな話を見かけたのでVBAで再現する回です。
実装
標準入力に1行書いて出力を読むだけ、かんたんですね!他の言語でもできると思います。久しぶりにVBAを書いたので、ベストプラクティスからは外れているかもしれません。
Option Explicit
Private Function EndsWith(strInput As String, strSuffix As String) As Boolean
Dim lInput As Long
lInput = Len(strInput)
Dim lSuffix As Long
lSuffix = Len(strSuffix)
If lSuffix > lInput Then
EndsWith = False
Else
EndsWith = (Right(strInput, lSuffix) = strSuffix)
End If
End Function
Private Function RemoveLastLine(strInput As String) As String
Dim i As Long
Dim ret As String
ret = ""
Dim arrLines As Variant
arrLines = Split(strInput, vbLf)
For i = LBound(arrLines) To UBound(arrLines) - 1
ret = ret & arrLines(i) & vbLf
Next i
ret = Left(ret, Len(ret) - Len(vbLf))
RemoveLastLine = ret
End Function
Private Sub ReadUntilNextPrompt(objInterpreter As Object, ByRef strOutput As String)
Dim PROMPT_LINE_START As String
PROMPT_LINE_START = ">>> "
Dim PROMPT_LINE_CONTINUE As String
PROMPT_LINE_CONTINUE = "... "
Do While objInterpreter.Status = 0 And Not (EndsWith(strOutput, PROMPT_LINE_START) Or EndsWith(strOutput, PROMPT_LINE_CONTINUE))
strOutput = strOutput & objInterpreter.StdOut.Read(1)
Loop
End Sub
Private Function CreateInterpreter(objWshShell As Object, ByRef strOutput As String) As Object
''' -i:スクリプト実行後に対話モードに入るオプション。なぜか含めないと動かない
''' cmd /c ~ 2>&1:">>>"など標準エラーに出力される内容を標準出力にリダイレクトする
Dim PYTHON_EXECUTABLE As String
PYTHON_EXECUTABLE = "cmd /c py.exe -i 2>&1"
Dim ret As Object
Set ret = objWshShell.Exec(PYTHON_EXECUTABLE)
ReadUntilNextPrompt ret, strOutput
Set CreateInterpreter = ret
End Function
Private Sub ExecuteScript(objInterpreter As Object, strScript As String, ByRef strOutput As String)
Dim strScriptWithNewLine As String
strScriptWithNewLine = strScript & vbLf
objInterpreter.StdIn.Write (strScriptWithNewLine)
strOutput = strOutput & strScriptWithNewLine
ReadUntilNextPrompt objInterpreter, strOutput
End Sub
Private Sub TerminateInterpreter(objInterpreter As Object)
If objInterpreter.Status = 0 Then
ExecuteScript objInterpreter, "exit()", ""
End If
objInterpreter.Terminate
Do While objInterpreter.Status = 0
DoEvents
Loop
End Sub
Function PY(strScript As String) As String
strScript = Replace(strScript, vbCrLf, vbLf)
Dim i As Long
Dim strOutput As String
strOutput = ""
Dim objWshShell As Object
Set objWshShell = CreateObject("WScript.Shell")
Dim objInterpreter As Object
Set objInterpreter = CreateInterpreter(objWshShell, strOutput)
Dim arrScripts As Variant
arrScripts = Split(strScript, vbLf)
For i = LBound(arrScripts) To UBound(arrScripts)
ExecuteScript objInterpreter, CStr(arrScripts(i)), strOutput
Next i
strOutput = Replace(strOutput, vbCrLf, vbLf)
strOutput = RemoveLastLine(strOutput) ' 最後の行は必ず">>> "
TerminateInterpreter objInterpreter
Set objInterpreter = Nothing
Set objWshShell = Nothing
PY = strOutput
End Function
はまりどころ
Exec
メソッドの戻り値であるWshScriptExec
オブジェクトでは子プロセスの標準入出力に触ることができますが、標準出力が空のときにRead
/ReadLine
/ReadAll
メソッドを実行するとブロックされます。しかし、ブロックせずにRead
できるかどうかを判別するよい手段が見当たりません。標準出力の末尾にいることを知る手段がないうえ、入力後にあるぶんだけ読み取るとブロックされて次の入力ができなくなるため、対話モードのような用途では使いづらくなっています1。
今回は、入力の開始を表すプロンプト>>>
と、入力の継続を表す...
までを読み込むと決めることで、この問題を回避しています。いつまでも>>>
が表示されないようなスクリプトを実行すると、Excelに帰ってこれなくなるということです。