Announcement

Collapse
No announcement yet.

I am having a tough time with PB9 and the MSScriptControl

Collapse
X
Collapse
 
  • Page of 1
  • Filter
  • Time
  • Show
Clear All
new posts
Previous template Next
    #1

    I am having a tough time with PB9 and the MSScriptControl

    I have been converting a (working) program from PB8 to PB9, involving the MSScript Control. I am not feeling good about the results. The code in the PB COM Browser generated file is quite different from PB8. I have tried to meet the requirements with some code which uses José's ideas. The .Run method does not work, and the whole object seem less than robust. This makes me think I have missed a conversion of a parameter. If anyone could look this over as you have a chance I would be most appreciative. The ScrCntl.Inc is the PB COM Browser generated file.

    This program is a cut down version of a larger program, but illustrates the issues.

    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()" & $CrLf
sCode = sCode & "MsgBox ""World""" & $CrLf
sCode = sCode & "End Sub" & $CrLf
ScriptCall "Language.Let", "VBScript"
'MsgBox ScriptCall("Language.Get", "")
ScriptCall "AddCode", sCode
ScriptCall "Run", "Main"
End Function

Function ScriptCall(Op As String, AValue As String) As String
Dim SC As Static IScriptControl
Dim pProcedures As IScriptProcedureCollection
Local sK, 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
  'MsgBox "pProcedures returned"
  sWork = Format$(pProcedures.Count)
  'MsgBox sWork
  If Val(sWork) > 0 Then
    sWork = SC.Procedures.Item(1).Name
    'MsgBox ACode$(sWork)
   Else
    MsgBox sWork
  End If
 Case "run"
  If SC.Procedures.Count = 0 Then
    MsgBox "No procedures available.", %mb_ok
    Exit Function
  End If
  VX = ""
  Try
    bDebugPsa = %True
    If IsTrue bDebugPsa Then
      SafeArrayGetElement psa, ByVal VarPtr(I), ByVal VarPtr(VX)
      lWork = VariantVT(VX)
      Select Case lWork
       Case 8, 30, 31
        sK = Variant$(VX)
        sK = "VT " & Format$(lWork) & " " & ACode$(sK)
       Case Else
        sK = "VT " & Format$(lWork) & " " & Format$(Variant#(VX))
      End Select
      'MsgBox sK
    End If
    sK = AValue
    Try
      sWork = SC.Procedures.Item(1).Name
      If ACode$(sWork) <> sK Then
        MsgBox "Procedure name problem"
      End If
      MsgBox "Running " & sK
      sK = UCode$(sK)
      VX = SC.Run(ByVal sK, ByVal psa)
    Catch
      SE = SC.Error
      MsgBox 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 8, 30, 31
      Function = Variant$(VX)
     Case Else
      Function = Format$(Variant#(VX))
    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
    Thank you so much for looking.

    Chuck de Young
    Tags: None
    #2
    Chuck,

    Just of the top of my head without really looking deeply into the code. Should the sCode not be converted to Unicode with UCode$ ?

    Don't shoot me when I'm off

    Cheers

    Steven
    So here we are, this is the end.
    But all that dies, is born again.
    - From The Ashes (In This Moment)

    Comment

      #3
      Sorry, now I see that you do that in the "AddCode" section.

      Sorry about this.
      So here we are, this is the end.
      But all that dies, is born again.
      - From The Ashes (In This Moment)

      Comment

        #4
        Dear Steven,

        Yes, that is one I caught. The SC.Procedures call to return the SC.Procedures.Item(1).Name comes back with "Main", but instead of running it I get a Error 99, "Object" error. The SE.Number is 0 (zero) and no SE.Description. I have tried a lot over the past few days, but I do not see where I am wrong.

        Thanks so much for looking.

        Chuck

        Comment

          #5
          You have to pass a valid safearray pointer, not a null one, and by reference, not by value.

          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
[B][COLOR="DarkRed"]LOCAL rgsabound AS SAFEARRAYBOUND[/COLOR][/B]
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()" & $CrLf
sCode = sCode & "MsgBox ""World""" & $CrLf
sCode = sCode & "End Sub" & $CrLf
ScriptCall "Language.Let", "VBScript"
'MsgBox ScriptCall("Language.Get", "")
ScriptCall "AddCode", sCode
ScriptCall "Run", "Main"
End Function

Function ScriptCall(Op As String, AValue As String) As String
Dim SC As Static IScriptControl
Dim pProcedures As IScriptProcedureCollection
Local sK, 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
  'MsgBox "pProcedures returned"
  sWork = Format$(pProcedures.Count)
  'MsgBox sWork
  If Val(sWork) > 0 Then
    sWork = SC.Procedures.Item(1).Name
    'MsgBox ACode$(sWork)
   Else
    MsgBox sWork
  End If
 Case "run"
  If SC.Procedures.Count = 0 Then
    MsgBox "No procedures available.", %mb_ok
    Exit Function
  End If
  VX = ""
  Try
    bDebugPsa = %True
    If IsTrue bDebugPsa Then
      SafeArrayGetElement psa, ByVal VarPtr(I), ByVal VarPtr(VX)
      lWork = VariantVT(VX)
      Select Case lWork
       Case 8, 30, 31
        sK = Variant$(VX)
        sK = "VT " & Format$(lWork) & " " & ACode$(sK)
       Case Else
        sK = "VT " & Format$(lWork) & " " & Format$(Variant#(VX))
      End Select
      'MsgBox sK
    End If
    sK = AValue
    Try
      sWork = SC.Procedures.Item(1).Name
      If ACode$(sWork) <> sK Then
        MsgBox "Procedure name problem"
      End If
      MsgBox "Running " & sK
      sK = UCode$(sK)
[B][COLOR="DarkRed"]      rgsabound.cLBound = 0
      rgsabound.cElements = 0
      psa = SafeArrayCreate(%VT_VARIANT, 1, rgsabound)
      VX = SC.Run(sK, VARPTR(psa))[/COLOR][/B]
    Catch
      SE = SC.Error
      MsgBox 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 8, 30, 31
      Function = Variant$(VX)
     Case Else
      Function = Format$(Variant#(VX))
    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
          Forum: http://www.jose.it-berater.org/smfforum/index.php

          Comment

            #6
            I can't wait to try it.

            Dear José,

            How I hate cutting down code and leaving out vital material! The psa was created correctly as the bDebugPsa section might have suggested. I lost that code somehow in the shortened version. This leaves me with the lack of the "Varptr(Psa)" as my mistake. In other words, I got the psa created correctly, but was passing it incorrectly. At least I hope the morning brings me to that happy conclusion. Thank you so much for looking. I knew you would be ahead of the game on this material.

            I will post the results of this change tomorrow, and I will add my psa creation code this time! Thanks again.

            Chuck

            Comment

              #7
              There is an example using the Run method in my forum:

              Interactive PowerBasic Forum - Index
              http://www.jose.it-berater.org/smfforum/index.php?topic=2225.0
              Interactive PowerBasic Forum - Index


              And other examples using other methods and properties here:

              Interactive PowerBasic Forum - Index
              http://www.jose.it-berater.org/smfforum/index.php?board=226.0
              Interactive PowerBasic Forum - Index


              I'm not using VARPTR(psa) in my example because in my include files I have the Run method declared as:

              Code:
                 ' =====================================================================================
   METHOD Run <2003> ( _                      ' VTable offset = 116
     BYVAL STRING _                           ' [in] BSTR ProcedureName
   , BYREF DWORD _                            ' [in] SAFEARRAY(VARIANT)* Parameters
   ) AS VARIANT                               ' [out, retval] VARIANT* pvarResult
   ' =====================================================================================
              Forum: http://www.jose.it-berater.org/smfforum/index.php

              Comment

                #8
                There is also an example that demonstrates how to add support for hosting VBScript to your PowerBASIC application.

                Interactive PowerBasic Forum - Index
                http://www.jose.it-berater.org/smfforum/index.php?topic=2264.0
                Interactive PowerBasic Forum - Index


                It embeds the vbscript engine and allows you to run scripts that can call the methods and properties of classes implemented in your own application.

                The Microsoft Script Control is just a wrapper on top of the IActiveScript interface written for VBers, that can't use IActiveScript directly.
                Forum: http://www.jose.it-berater.org/smfforum/index.php

                Comment

                  #9
                  Your examples

                  Dear José,

                  Your examples were very valuable in guiding me in my use of the VBScript engine. I used JazzAge years ago to include scripting in my applications, and successfully used PB8's object technology when it came out, but the differing parameter passing structure was throwing me in my conversion to PB9. The error message is the same with the code I omitted, "object error 99" and se.number a zero.

                  The JazzAge heritage is the reason I used the Microsoft ScriptControl, but I will take a look at your more direct interface to the engine.

                  Thanks again for the time you took to guide me.

                  Chuck

                  Comment

                    #10
                    Working code

                    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
                    Last edited by Chuck de Young; 3 Sep 2008, 09:10 AM. Reason: Remove un-needed code

                    Comment

                    Previous template Next
                    Working...
                    X
                    😀
                    🥰
                    🤢
                    😎
                    😡
                    👍
                    👎

                    We process personal data about users of our site, through the use of cookies and other technologies, to deliver our services, and to analyze site activity. For additional details, refer to our Privacy Policy.

                    By clicking "I AGREE" below, you agree to our Privacy Policy and our personal data processing and cookie practices as described therein. You also acknowledge that this forum may be hosted outside your country and you consent to the collection, storage, and processing of your data in the country where this forum is hosted.

                    I Agree