- Код: Выделить всё
Sub Main()
Dim vbs As Object
Set vbs = CreateObject("ScriptControl")
vbs.language = "VBSCRIPT"
Dim Code$
Code = Code & "Function F0()" & vbCrLf
Code = Code & "F0=0" & vbCrLf
Code = Code & "End Function" & vbCrLf
Code = Code & "Function F1(a0)" & vbCrLf
Code = Code & "F1=10:a0=11" & vbCrLf
Code = Code & "End Function" & vbCrLf
Code = Code & "Function F2(a0,a1)" & vbCrLf
Code = Code & "F2=20:a0=21:a1=22" & vbCrLf
Code = Code & "End Function" & vbCrLf
Code = Code & "Function F3(a0,a1,a2)" & vbCrLf
Code = Code & "F3=30:a0=31:a1=32:a2=33" & vbCrLf
Code = Code & "End Function" & vbCrLf
Code = Code & "Function F4(a0,a1,a2,a3)" & vbCrLf
Code = Code & "F4=40:a0=41:a1=42:a2=43:a3=44" & vbCrLf
Code = Code & "End Function" & vbCrLf
vbs.addcode Code
Dim c0, c1, c2, c3
Debug.Print vbs.Run("F0")
Debug.Print vbs.Run("F1", c0), c0
Debug.Print vbs.Run("F2", c0, c1), c0, c1
Debug.Print vbs.Run("F3", c0, c1, c2), c0, c1, c2
Debug.Print vbs.Run("F4", c0, c1, c2, c3), c0, c1, c2, c3
Dim b0, b1, b2, b3
b0 = 100
b1 = 101
b2 = 102
b3 = 103
Debug.Print ScriptControl_Run2(vbs, "F0")
Debug.Print ScriptControl_Run2(vbs, "F1", b0), b0
Debug.Print ScriptControl_Run2(vbs, "F2", b0, b1), b0, b1
Debug.Print ScriptControl_Run2(vbs, "F3", b0, b1, b2), b0, b1, b2
Debug.Print ScriptControl_Run2(vbs, "F4", b0, b1, b2, b3), b0, b1, b2, b3
b0 = 1000
b1 = 1001
b2 = 1002
b3 = 1003
Debug.Print ScriptControl_Run1(vbs, "F0")
Debug.Print ScriptControl_Run1(vbs, "F1", b0), b0
Debug.Print ScriptControl_Run1(vbs, "F2", b0, b1), b0, b1
Debug.Print ScriptControl_Run1(vbs, "F3", b0, b1, b2), b0, b1, b2
Debug.Print ScriptControl_Run1(vbs, "F4", b0, b1, b2, b3), b0, b1, b2, b3
End Sub
мне нужно передавать аргументы в функцию и забирать их обратно (нутром чуствую что решение гдето рядом)
такое работает:
- Код: Выделить всё
Function ScriptControl_Run2(eVBS As Object, ProcedureName As String, ParamArray Parameters() As Variant)
Dim res As Variant
Select Case UBound(Parameters)
Case -1
res = eVBS.Run(ProcedureName)
Case 0
res = eVBS.Run(ProcedureName, Parameters(0))
Case 1
res = eVBS.Run(ProcedureName, Parameters(0), Parameters(1))
Case 2
res = eVBS.Run(ProcedureName, Parameters(0), Parameters(1), Parameters(2))
Case 3
res = eVBS.Run(ProcedureName, Parameters(0), Parameters(1), Parameters(2), Parameters(3))
'Case 4
'Case 5
'Case 11
End Select
ScriptControl_Run2 = res
End Function
а такое (не работает = не может принять ParamArray ):
- Код: Выделить всё
Private Declare Function rtcCallByName Lib "MSVBVM60.dll" (ByVal Object As Object, ByVal ProcName As Long, ByVal CallType As VbCallType, ByRef Args() As Any, Optional ByVal lcid As Long) As Variant
Function ScriptControl_Run1(eVBS As Object, ProcedureName As String, ParamArray Parameters())
If UBound(Parameters) = -1 Then
ScriptControl_Run1 = eVBS.Run(ProcedureName)
Else
'вот здесь не работает
ScriptControl_Run1 = CallByName(eVBS.CodeObject, ProcedureName, VbMethod, Parameters)
'и тут тоже
ScriptControl_Run1 = rtcCallByName(eVBS.CodeObject, ProcedureName, VbMethod, Parameters)
End If
End Function
