Announcement

Collapse
No announcement yet.

I am having a tough time with PB9 and the MSScriptControl

Collapse
X
 
  • Filter
  • Time
  • Show
Clear All
new posts

  • 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

  • #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
          LOCAL rgsabound AS SAFEARRAYBOUND
          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)
                rgsabound.cLBound = 0
                rgsabound.cElements = 0
                psa = SafeArrayCreate(%VT_VARIANT, 1, rgsabound)
                VX = SC.Run(sK, VARPTR(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
          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:

              http://www.jose.it-berater.org/smffo...p?topic=2225.0

              And other examples using other methods and properties here:

              http://www.jose.it-berater.org/smffo...hp?board=226.0

              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.

                http://www.jose.it-berater.org/smffo...p?topic=2264.0

                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, 10:10 AM. Reason: Remove un-needed code

                    Comment

                    Working...
                    X