Here is the working code with José Roca's suggestion of passing the parameter array as the address of the psa. I have included the missing psa generation, and added the 'Evaluate" and "Execute" calls as examples.
Thanks again to José Roca for making my morning much brighter.
Code:
#Compile Exe
Option Explicit
#Include "C:\PBWin90\WinAPI\Win32API.Inc"
#Include "C:\PBWin90\WinAPI\VBAPI32.Inc"
#Include "ScrCntl.Inc"
'
' SAFEARRAY API
'
Declare Function SafeArrayCreate Lib "oleaut32.DLL" Alias "SafeArrayCreate"(ByVal vt As Word, ByVal cDims As Dword,ByRef rgsabounds As SAFEARRAYBOUND) As Dword
Declare Function SafeArrayDestroy Lib "oleaut32.DLL" Alias "SafeArrayDestroy"(ByVal hsa As Dword) As Dword
Declare Function SafeArrayPutElement Lib "oleaut32.DLL" Alias "SafeArrayPutElement"(ByVal hsa As Dword,ByRef rgIndices As Long,ByVal pvData As Dword) As Dword
Function PBMain () As Long
Local sCode As String
sCode = ""
sCode = sCode & "Option Explicit" & $CrLf
sCode = sCode & "" & $CrLf
sCode = sCode & "MsgBox ""Hello""" & $CrLf
sCode = sCode & "" & $CrLf
sCode = sCode & "Sub Main(A, B)" & $CrLf
sCode = sCode & "MsgBox A & "" for the "" & B & ""nd time""" & $CrLf
sCode = sCode & "End Sub" & $CrLf
ScriptCall "Language.Let", "VBScript"
ScriptCall "AddCode", sCode
ScriptCall "Run", "Main"
MsgBox ScriptCall("Evaluate", "14.97 * 1.0575")
ScriptCall "Execute", "MsgBox 522 + 747"
End Function
Function ScriptCall(Op As String, AValue As String) As String
Dim SC As Static IScriptControl
Dim pProcedures As IScriptProcedureCollection
Local sK, sP, sWork As String
Local VX As Variant
Local rgsabound As SAFEARRAYBOUND
Local SE As IScriptError
Local Params, psa As Dword
Local I, RetVal As Long
Local lWork, bDebugPsa As Long
If IsFalse IsObject(SC) Then
Try
SC = NewCom $PROGID_MSScriptControl_ScriptControl
If IsFalse IsObject(SC) Then
MsgBox "SC not an object", %mb_ok, "Instance"
End If
Catch
SE = SC.Error
MsgBox Format$(Err) & " " & Error$(ErrClear) & $Lf & " " & Format$(SE.Number) & " " & ACode$(SE.Description), %mb_ok, "Instance"
End Try
End If
Select Case LCase$(Op)
Case "timeout.let"
SC.Timeout = Val(AValue)
Case "timeout.get"
Function = Format$(SC.Timeout)
Case "language.let" ' Place the passed value into SC as chosen scripting language.
SC.Language = UCode$(AValue)
Case "language.get" ' Return the current language.
Try
sWork = SC.Language
Function = ACode$(sWork)
Catch
SE = SC.Error
MsgBox Format$(Err) & " " & Error$(ErrClear) & $Lf & " " & Format$(SE.Number) & " " & ACode$(SE.Description), %mb_ok, "Language.Get"
End Try
Case "addcode" ' Add code to SC, code passed in as AValue.
SC.AddCode UCode$(AValue)
pProcedures = SC.Procedures
sWork = Format$(pProcedures.Count)
If Val(sWork) > 0 Then
sWork = SC.Procedures.Item(1).Name
Else
MsgBox sWork
End If
Case "run"
Try
If SC.Procedures.Count = 0 Then
MsgBox "No procedures available.", %mb_ok
Exit Function
End If
Try
sWork = SC.Procedures.Item(1).Name
If ACode$(sWork) <> AValue Then
MsgBox "Procedure name problem"
End If
rgsabound.cLBound = 0
rgsabound.cElements = 2
psa = SafeArrayCreate(%vt_variant, 1, rgsabound)
sWork = "World"
VX = sWork
I = 0
RetVal = SafeArrayPutElement(psa, I, ByVal VarPtr(VX))
VX = 2
I = 1
RetVal = SafeArrayPutElement(psa, I, ByVal VarPtr(VX))
bDebugPsa = %True
If IsTrue bDebugPsa Then
sK = EvaluateArg(psa, 0)
sP = EvaluateArg(psa, 1)
MsgBox "Running " & AValue & $Lf & "Passing in parameter A as " & sK & $Lf & "Passing in parameter B as " & sP
End If
sK = UCode$(AValue)
VX = SC.Run(sK, VarPtr(psa))
Catch
SE = SC.Error
MsgBox "Running " & ACode$(sK) & $Lf & Format$(Err) & " " & Error$(ErrClear) & $Lf & " " & Format$(SE.Number) & " " & ACode$(SE.Description), %mb_ok, "SC.Run"
Finally
Function = Variant$(VX)
End Try
Catch
SE = SC.Error
MsgBox Format$(Err) & " " & Error$(ErrClear) & $Lf & " " & Format$(SE.Number) & " " & ACode$(SE.Description), %mb_ok, "Run"
Finally
If psa Then SafeArrayDestroy psa
Function = Variant$(VX)
End Try
Case "evaluate"
sK = UCode$(AValue)
Try
VX = SC.Eval(sK)
Select Case VariantVT(VX)
Case %vt_bstr, %vt_lpstr
Function = Variant$(VX)
Case %vt_lpwstr
Function = ACode$(Variant$(VX))
Case %vt_i2 To %vt_cy
Function = Format$(Variant#(VX))
Case Else
Function = "VT " & Format$(lWork) & " unevaluated"
End Select
Catch
SE = SC.Error
MsgBox Format$(Err) & " " & Error$(ErrClear) & $Lf & " " & Format$(SE.Number) & " " & ACode$(SE.Description), %mb_ok, "Eval"
End Try
Case "execute"
sK = UCode$(AValue)
Try
SC.ExecuteStatement sK
Catch
SE = SC.Error
MsgBox Format$(Err) & " " & Error$(ErrClear) & $Lf & " " & Format$(SE.Number) & " " & ACode$(SE.Description), %mb_ok, "Execute"
End Try
Case "close"
Set SC = Nothing
End Select
End Function
Function EvaluateArg(psa As Dword, I As Long) As String
Local sWork As String
Local VX As Variant
Local lWork As Long
SafeArrayGetElement psa, I, ByVal VarPtr(VX)
lWork = VariantVT(VX)
Select Case lWork
Case %vt_bstr, %vt_lpstr
sWork = Variant$(VX)
Function = "VT " & Format$(lWork) & " " & sWork
Case %vt_lpwstr
sWork = Variant$(VX)
Function = "VT " & Format$(lWork) & " " & ACode$(sWork)
Case %vt_i2 To %vt_cy
Function = "VT " & Format$(lWork) & " " & Format$(Variant#(VX))
Case Else
Function = "VT " & Format$(lWork) & " unevaluated"
End Select
End Function
Leave a comment: