It is currently Tue Nov 12, 2019 6:57 pm

All times are UTC + 1 hour




Post new topic Reply to topic  [ 30 posts ]  Go to page 1, 2  Next
Author Message
 Post subject: Module ActiveScript for VB-Script with PB-Runtime Variables
PostPosted: Sun Sep 16, 2018 1:06 am 
Offline
Addict
Addict
User avatar

Joined: Fri May 12, 2006 6:51 pm
Posts: 2020
Location: Germany
Since the old ScriptControl of ts-soft and me doesn't work under X64, I have been working with ActiveScript.

Here the control with an integrated AddOn "Runtime - Integrates runtime variables from Purebasic into VB-Script".

The AddOns are added to the ActiveScript control with the function AddNamedObject(SpaceName, *Object). The objects are released again when the ActiveScript control exits.
The type on of the AddOns must be an object with the interface IDispatch.

The DebuggerLevel is set to 4 in the Common module to activate the debug output.

Update v1.06
- Added Runtime.Sleep [milliseconds]

Update v1.07
- Added Runtime.Trace
- Const AutoContinue

Update v1.08
- Runtime.Trace output now to MS-DebugView

Update v1.09
- Added JavaScript support
- Change ActiveScriptCommon Constants
* #UseActiveScriptInterruptPull = #False
* #UseActiveScriptDebugView = #True

Update v2.01
- Multiple instances can now be started
- Added additional parameter for instance
- Change AddObject to AddNamedObject

Update v2.02
- Added Runtime.Call(Name, Parameters, ...)

Syntax Callback:
Runtime Procedure Name(cArgs.i, *vArgs, *vResult.Variant)
- cArgs: Count of Parameters
- *vArgs: Pointer to Array of Parameters as Variant. Reverse order of parameters
- *vResult: Pointer to Result as Variant (ByRef). Is Zero by call as Method (Sub Name)

Update v2.04
- Bugfix X86

Update v2.06
- Bugfix Refcounter from ActiveScriptParse, etc

Modul_ActiveScript.pb
Code:
;-TOP

; Comment   : Modul ActiveScript
; Author    : mk-soft
; Version   : v2.06r2
; Create    : 15.09.2018
; Update    : 01.06.2019

; Link to ActiveScript  : https://www.purebasic.fr/english/viewtopic.php?f=12&t=71399
; Link to SmartTags     : https://www.purebasic.fr/english/viewtopic.php?f=12&t=71399#p527089
; Link to VariantHelper : https://www.purebasic.fr/english/viewtopic.php?f=12&t=71399#p527090

; Base of Module : Josh - http://forums.purebasic.com/german/viewtopic.php?f=3&t=21781

; ***************************************************************************************

; Descriptions Control:
;
; *Control = NewActiveScript(Language) : Create and initialze active script control
; - FreeActiveScript(*Control) : Release script control
; - ParseScriptText(*Control, Script) : Added and run scripts
; - AddNamedObject(*Control, Name, *Object) : Added own named objects with interface type IDispatch
;
; Descriptions Addon Runtime:
;   Bind Runtime variables and procedures to script
;
; - Runtime.[Integer, Double, String](RuntimeName) : Get and put runtime variables
; - Runtime.Sleep Time : Delay for script in milliseconds
; - Runtime.Trace Text: Trace output to MS DebugView
; - Runtime.Call(RuntimeName, Parameters, ...) : Call a runtime procedure as callback
;
; * Syntax Runtime Callback:
;
;   Runtime Procedure Name(cArgs.i, *vArgs, *vResult.Variant)
;   - cArgs: Count of Parameters
;   - *vArgs: Pointer To Array of Parameters As Variant. Reverse order of parameters
;   - *vResult: Pointer To Result As Variant (ByRef). Is Zero by call As Method (Sub Name)

; ***************************************************************************************

CompilerIf #PB_Compiler_Unicode = 0
  CompilerError "Use Compiler-Option Unicode"
CompilerEndIf

; ***************************************************************************************

;- Module ActiveScriptCommon

DeclareModule ActiveScriptCommon
 
  ; Active Debuglevel
  #DebugLevel = 4
 
  ; Define Debuglevel
  #DebugLevelRuntime      = 3
  #DebugLevelActiveScript = 4
 
  #UseActiveScriptInterruptPull = #False
  #UseActiveScriptDebugView     = #True
 
  ; -----------------------------------------------------------------------------------
 
  ;-- Constants
 
  #SCRIPTTEXT_DELAYEXECUTION    = $00000001
  #SCRIPTTEXT_ISVISIBLE         = $00000002
  #SCRIPTTEXT_ISEXPRESSION      = $00000020
  #SCRIPTTEXT_ISPERSISTENT      = $00000040
  #SCRIPTTEXT_HOSTMANAGESSOURCE = $00000080
  #SCRIPTTEXT_ISXDOMAIN         = $00000100
  #SCRIPTTEXT_ISNONUSERCODE     = $00000200
 
  #SCRIPTSTATE_UNINITIALIZED = 0
  #SCRIPTSTATE_INITIALIZED   = 5
  #SCRIPTSTATE_STARTED       = 1
  #SCRIPTSTATE_CONNECTED     = 2
  #SCRIPTSTATE_DISCONNECTED  = 3
  #SCRIPTSTATE_CLOSED        = 4
 
  #SCRIPTITEM_ISVISIBLE      = $0000002
  #SCRIPTITEM_ISSOURCE       = $0000004
  #SCRIPTITEM_GLOBALMEMBERS  = $0000008
  #SCRIPTITEM_ISPERSISTENT   = $0000040
  #SCRIPTITEM_CODEONLY       = $0000200
  #SCRIPTITEM_NOCODE         = $0000400
 
  #SCRIPTINFO_IUNKNOWN       = 1
  #SCRIPTINFO_ITYPEINFO      = 2
 
  ; -----------------------------------------------------------------------------------
 
  ;-- Interface
 
  Interface IActiveScript
    QueryInterface(riid, ppvObject)
    AddRef()
    Release()
    SetScriptSite(pass)
    GetScriptSite(riid, ppvObject)
    SetScriptState(ssState)
    GetScriptState(pssState)
    Close()
    AddNamedItem(pstrName, dwFlags)
    AddTypeLib(rguidTypeLib, dwMajor, dwMinor, dwFlags)
    GetScriptDispatch(pstrItemName, ppdisp)
    GetCurrentScriptThreadID(pstidThread)
    GetScriptThreadID(dwWin32ThreadId, pstidThread)
    GetScriptThreadState(stidThread, pstsState)
    InterruptScriptThread(stidThread, pexcepinfo, dwFlags)
    Clone(ppscript)
  EndInterface
 
  Interface IActiveScriptParse
    QueryInterface(riid, ppvObject)
    AddRef()
    Release()
    InitNew()
    AddScriptlet(pstrDefaultName, pstrCode, pstrItemName, pstrSubItemName, pstrEventName,
                 pstrDelimiter, dwSourceContextCookie, ulStartingLineNumber, dwFlags, pbstrName, pexcepinfo)
    ParseScriptText(pstrCode, pstrItemName, punkContext, pstrDelimiter, dwSourceContextCookie,
                    ulStartingLineNumber, dwFlags, pvarResult, pexcepinfo)
  EndInterface
 
  Interface IActiveScriptSite
    QueryInterface(riid, ppvObject)
    AddRef()
    Release()
    GetLCID(plcid)
    GetItemInfo(pstrName, dwReturnMask, ppiunkItem, ppti)
    GetDocVersionString(pbstrVersion)
    OnScriptTerminate(pvarResult, pexcepinfo)
    OnStateChange(ssScriptState)
    OnScriptError(pscripterror)
    OnEnterScript()
    OnLeaveScript()
  EndInterface
 
  Interface IActiveScriptSiteWindow
    QueryInterface(riid, ppvObject)
    AddRef()
    Release()
    GetWindow(pWindowId)
    EnableModless(fEnable)
  EndInterface
 
  Interface IActiveScriptSiteInterruptPoll
    QueryInterface(riid, ppvObject)
    AddRef()
    Release()
    QueryContinue()
  EndInterface
 
  Interface IActiveScriptError
    QueryInterface(riid, ppvObject)
    AddRef()
    Release()
    GetExceptionInfo(pexcepinfo)
    GetSourcePosition(pdwSourceContext, pulLineNumber, plCharacterPosition)
    GetSourceLineText(pbstrSourceLine)
    CompilerIf #PB_Compiler_Processor = #PB_Processor_x64
      GetSourcePosition64(pdwSourceContext, pulLineNumber, plCharacterPosition)
    CompilerEndIf
  EndInterface
 
  ; -----------------------------------------------------------------------------------
 
  ;-- Structure
 
  Structure objActiveNamedItems
    Name.s
    *Object.IDispatch
    Type.i
  EndStructure
 
  Structure objActiveScriptControl
    *ActiveScript.IActiveScript
    *ActiveScriptParse.IActiveScriptParse
    *ActiveScriptSite.IActiveScriptSite
    Map NamedItems.objActiveNamedItems()
  EndStructure
 
  ; -----------------------------------------------------------------------------------
 
  ;-- DataSection
 
  DataSection
   
    IID_IUnknown: ; {00000000-0000-0000-C000-000000000046}
    Data.l $00000000
    Data.w $0000, $0000
    Data.b $C0, $00, $00, $00, $00, $00, $00, $46
   
    IID_IDispatch: ; {00020400-0000-0000-C000-000000000046}
    Data.l $00020400
    Data.w $0000, $0000
    Data.b $C0, $00, $00, $00, $00, $00, $00, $46
   
    IID_IDispatchEx: ; {A6EF9860-C720-11D0-9337-00A0C90DCAA9}
    Data.l $A6EF9860
    Data.w $C720, $11D0
    Data.b $93, $37, $00, $A0, $C9, $0D, $CA, $A9
   
    IID_IActiveScript:  ; {BB1A2AE1-A4F9-11CF-8F20-00805F2CD064}
    Data.l $BB1A2AE1
    Data.w $A4F9, $11CF
    Data.b $8F, $20, $00, $80, $5F, $2C, $D0, $64
   
    IID_IActiveScriptSite:  ; {DB01A1E3-A42B-11CF-8F20-00805F2CD064}
    Data.l $DB01A1E3
    Data.w $A42B, $11CF
    Data.b $8F, $20, $00, $80, $5F, $2C, $D0, $64
   
    IID_IActiveScriptSiteInterruptPoll: ; {539698A0-CDCA-11CF-A5EB-00AA0047A063}
    Data.l $539698A0
    Data.w $CDCA, $11CF
    Data.b $A5, $EB, $00, $AA, $00, $47, $A0, $63
   
    IID_IActiveScriptSiteWindow:  ; {DB01A1E3-A42B-11CF-8F20-00805F2CD064}
    Data.l $D10F6761
    Data.w $83E9, $11CF
    Data.b $8F, $20, $00, $80, $5F, $2C, $D0, $64
   
    IID_IActiveScriptSiteTraceInfo: ; {4B7272AE-1955-4BFE-98B0-780621888569}
    Data.l $4B7272AE
    Data.w $1955, $4BFE
    Data.b $98, $B0, $78, $06, $21, $88, $85, $69
   
    IID_IActiveScriptSiteUIControl: ; {AEDAE97E-D7EE-4796-B960-7F092AE844AB}
    Data.l $AEDAE97E
    Data.w $D7EE, $4796
    Data.b $B9, $60, $7F, $09, $2A, $E8, $44, $AB
   
    CompilerIf #PB_Compiler_Processor = #PB_Processor_x86
      IID_IActiveScriptParse:  ; {BB1A2AE2-A4F9-11CF-8F20-00805F2CD064} 32 bit
      Data.l $BB1A2AE2
      Data.w $A4F9, $11CF
      Data.b $8F, $20, $00, $80, $5F, $2C, $D0, $64
    CompilerEndIf
   
    CompilerIf #PB_Compiler_Processor = #PB_Processor_x64
      IID_IActiveScriptParse:  ; {C7EF7658-E1EE-480E-97EA-D52CB4D76D17} 64 bit
      Data.l $C7EF7658
      Data.w $E1EE, $480E
      Data.b $97, $EA, $D5, $2C, $B4, $D7, $6D, $17
    CompilerEndIf
   
    CompilerIf #PB_Compiler_Processor = #PB_Processor_x86
      IID_IActiveScriptSiteDebug: ; {51973C11-CB0C-11D0-B5C9-00A0244A0E7A} 32 bit
      Data.l $51973C11
      Data.w $CB0C, $11D0
      Data.b $B5, $C9, $00, $A0, $24, $4A, $0E, $7A
    CompilerEndIf
   
    CompilerIf #PB_Compiler_Processor = #PB_Processor_x64
      IID_IActiveScriptSiteDebug: ; {D6B96B0A-7463-402C-92AC-89984226942F} 64 bit
      Data.l $D6B96B0A
      Data.w $7463, $402C
      Data.b $92, $AC, $89, $98, $42, $26, $94, $2F
    CompilerEndIf
   
  EndDataSection
 
  ; -----------------------------------------------------------------------------------
 
  ;-- Public Funtions
 
  Declare.s GetGuidString(*Guid.GUID)
 
  ; -----------------------------------------------------------------------------------
 
EndDeclareModule

; ---

Module ActiveScriptCommon
 
  EnableExplicit
 
  DebugLevel #DebugLevel
 
  ; -----------------------------------------------------------------------------------
 
  Procedure.s GetGuidString(*Guid.GUID)
    Protected msg.s
    msg = "{"
    msg + RSet (Hex(*Guid\Data1  , #PB_Long), 8, "0") + "-"
    msg + RSet (Hex(*Guid\Data2  , #PB_Word), 4, "0") + "-"
    msg + RSet (Hex(*Guid\Data3  , #PB_Word), 4, "0") + "-"
    msg + RSet (Hex(*Guid\Data4[0], #PB_Byte), 2, "0")
    msg + RSet (Hex(*Guid\Data4[1], #PB_Byte), 2, "0") + "-"
    msg + RSet (Hex(*Guid\Data4[2], #PB_Byte), 2, "0")
    msg + RSet (Hex(*Guid\Data4[3], #PB_Byte), 2, "0")
    msg + RSet (Hex(*Guid\Data4[4], #PB_Byte), 2, "0")
    msg + RSet (Hex(*Guid\Data4[5], #PB_Byte), 2, "0")
    msg + RSet (Hex(*Guid\Data4[6], #PB_Byte), 2, "0")
    msg + RSet (Hex(*Guid\Data4[7], #PB_Byte), 2, "0")
    msg + "}"
    ProcedureReturn msg
  EndProcedure
 
  ; ---------------------------------------------------------------------------
 
EndModule

; ***************************************************************************************

;- Module ActiveScriptRuntime - Integrates runtime variables from Purebasic into VB-Script

DeclareModule ActiveScriptRuntime
 
  Declare New()
 
EndDeclareModule

Module ActiveScriptRuntime
 
  EnableExplicit
 
  UseModule ActiveScriptCommon
 
  DebugLevel #DebugLevel
 
  ; -----------------------------------------------------------------------------------
 
  Enumeration 1
    #DispID_RuntimeCall
    #DispId_RuntimeInteger
    #DispId_RuntimeDouble
    #DispId_RuntimeString
    #DispId_RuntimeSleep
    #DispId_RuntimeTrace
  EndEnumeration
 
  Structure objRuntime
    *VTABLE
    cntRef.i
  EndStructure
 
  Structure udtArgs
    Value.Variant[0]
  EndStructure
 
  Prototype protoRuntimeProc(cArgs, *Args.udtArgs, *pResult.Variant)
 
  ; -----------------------------------------------------------------------------------
 
  Procedure CheckVT(*var.VARIANT, Type)
    If (*var\vt & #VT_TYPEMASK) <> Type
      ProcedureReturn #DISP_E_BADVARTYPE
    Else
      ProcedureReturn #S_OK
    EndIf
  EndProcedure
 
  ; -----------------------------------------------------------------------------------
 
  Procedure.s VT_STR(*Var.Variant)
    Protected hr, result.s, VarDest.Variant
    If *Var
      If *Var\vt = #VT_BSTR
        result = PeekS(*Var\bstrVal, #PB_Any, #PB_Unicode)
        ProcedureReturn result
      Else
        hr = VariantChangeType_(VarDest, *Var, 0, #VT_BSTR)
        If hr = #S_OK
          result = PeekS(VarDest\bstrVal, #PB_Any, #PB_Unicode)
          VariantClear_(VarDest)
          ProcedureReturn result
        Else
          ProcedureReturn ""
        EndIf
      EndIf
    EndIf
  EndProcedure
 
  ; -----------------------------------------------------------------------------------
 
  ; Begin Standard Interfaces
 
  Procedure QueryInterface(*This.objRuntime, *iid.IID, *Object.Integer)
   
    ; Standardzuweisungen auf eigenes Objekt
    If CompareMemory(*iid, ?IID_IUnknown, 16)
      Debug "Runtime - QueryInterface() : IUnknown -> Ok", #DebugLevelRuntime
      *Object\i = *This
      *This\cntRef + 1
      ProcedureReturn #S_OK
    ElseIf CompareMemory(*iid, ?IID_IDispatch, 16)
      Debug "Runtime - QueryInterface() : IDispatch -> Ok", #DebugLevelRuntime
      *Object\i = *This
      *This\cntRef + 1
      ProcedureReturn #S_OK
    ElseIf CompareMemory(*iid, ?IID_IDispatchEx, 16)
      ; Debug "Runtime - QueryInterface() : IDispatchEx -> No Interface", #DebugLevelRuntime
      *Object\i = 0
      ProcedureReturn #E_NOINTERFACE
    Else
      Debug "Runtime - QueryInterface() : No Interface", #DebugLevelRuntime
      *Object\i = 0
      ProcedureReturn #E_NOINTERFACE
    EndIf
   
  EndProcedure
 
  ; -----------------------------------------------------------------------------------
 
  Procedure AddRef(*This.objRuntime)
   
    Debug "Runtime - AddRef() :  Refcount = " + Str(*This\cntRef) + " > " + Str(*This\cntRef + 1), #DebugLevelRuntime
    *This\cntRef + 1
    ProcedureReturn *This\cntRef
   
  EndProcedure
 
  ; -----------------------------------------------------------------------------------
 
  Procedure Release(*This.objRuntime)
   
    Debug "Runtime - Release() : Refcount = " + Str(*This\cntRef) + " > " + Str(*This\cntRef - 1), #DebugLevelRuntime
    *This\cntRef - 1
    If *This\cntRef < 1
      FreeStructure(*This)
      ProcedureReturn 0
    Else
      ProcedureReturn *This\cntRef
    EndIf
  EndProcedure
 
  ; -----------------------------------------------------------------------------------
 
  Procedure GetTypeInfoCount(*This.objRuntime, *CntTypeInfo.Long)
    *CntTypeInfo\l = 0
    ProcedureReturn #S_OK
  EndProcedure
 
  ; -----------------------------------------------------------------------------------
 
  Procedure GetTypeInfo(*This.objRuntime, TypeInfo.l, LocalId.l, *ppTypeInfo.Integer)
    ProcedureReturn #E_NOTIMPL
  EndProcedure
 
  ; -----------------------------------------------------------------------------------
 
  Procedure GetIDsOfNames(*This.objRuntime, *iid.IID, *Name.String, cntNames.l, lcid.l, *DispId.Long)
   
    Protected Name.s
   
    Name = LCase(*Name\s)
   
    ; Hier die Funktionsnamen auf DispId auflösen
    Select name
      Case "integer"
        *DispId\l = #DispId_RuntimeInteger
      Case "double"
        *DispId\l = #DispId_RuntimeDouble
      Case "string"
        *DispId\l = #DispId_RuntimeString
      Case "call"
        *DispId\l = #DispID_RuntimeCall
      Case "sleep"
        *DispId\l = #DispId_RuntimeSleep
      Case "trace"
        *DispId\l = #DispId_RuntimeTrace
      Default
        Debug "Runtime - GetIDsOfNames() : Member Not Found", #DebugLevelRuntime
        ProcedureReturn #DISP_E_MEMBERNOTFOUND
       
    EndSelect
   
    Debug "Runtime - GetIDsOfNames() : Name = " + Name + " -> DispId = " + *DispId\l, #DebugLevelRuntime
   
    ProcedureReturn #S_OK
   
  EndProcedure
 
  ; -----------------------------------------------------------------------------------
 
  Procedure Invoke(*This.objRuntime, DispId.l, *iid.IID, lcid.l, Flags.w, *DispParams.DISPPARAMS, *vResult.VARIANT, *ExcepInfo.EXCEPINFO, *ArgErr.Integer)
   
    Protected cArgs, *vArgs.udtArgs, name.s, value.variant, *Call.protoRuntimeProc, t1
   
    cArgs  = *DispParams\cArgs
    *vArgs = *DispParams\rgvarg
   
    Select DispId
      Case #DispID_RuntimeCall
        If Flags & #DISPATCH_PROPERTYGET
          ; Hier werden die Anzahl der Parameter überprüft
          If cArgs < 1
            ProcedureReturn #DISP_E_BADPARAMCOUNT
          EndIf
          ; Hier werden die Typen der Parameter überprüft
          cArgs - 1
          If CheckVT(*vArgs\Value[cArgs], #VT_BSTR)
            ProcedureReturn #DISP_E_BADVARTYPE
          EndIf
          name = VT_STR(*vArgs\Value[cArgs])
          Debug "Runtime - Invoke() PropertyGet - Call : " + name, #DebugLevelRuntime
          If IsRuntime(name) And Right(name,2) = "()"
            *Call = GetRuntimeInteger(name)
            If *Call
              ProcedureReturn *Call(cArgs, *vArgs, *vResult)
            EndIf
          Else
            ProcedureReturn #DISP_E_BADINDEX
          EndIf
         
        ElseIf Flags & #DISPATCH_METHOD
          ; Hier werden die Anzahl der Parameter überprüft
          If cArgs < 1
            ProcedureReturn #DISP_E_BADPARAMCOUNT
          EndIf
          ; Hier werden die Typen der Parameter überprüft
          cArgs - 1
          If CheckVT(*vArgs\Value[cArgs], #VT_BSTR)
            ProcedureReturn #DISP_E_BADVARTYPE
          EndIf
          name = VT_STR(*vArgs\Value[cArgs])
          Debug "Runtime - Invoke() Method - Call : " + name, #DebugLevelRuntime
          If IsRuntime(name) And Right(name,2) = "()"
            *Call = GetRuntimeInteger(name)
            If *Call
              ProcedureReturn *Call(cArgs, *vArgs, 0) ; No Result
            EndIf
          Else
            ProcedureReturn #DISP_E_BADINDEX
          EndIf
        EndIf
       
      Case #DispId_RuntimeInteger
        If Flags & #DISPATCH_PROPERTYGET
          ; Hier werden die Anzahl der Parameter überprüft
          If cArgs <> 1
            ProcedureReturn #DISP_E_BADPARAMCOUNT
          EndIf
          ; Hier werden die Typen der Parameter überprüft
          If CheckVT(*vArgs\Value[0], #VT_BSTR)
            ProcedureReturn #DISP_E_BADVARTYPE
          EndIf
          name = VT_STR(*vArgs\Value[0])
          Debug "Runtime - Invoke() PropertyGetInteger : " + name, #DebugLevelRuntime
          If IsRuntime(name)
            CompilerIf #PB_Compiler_Processor = #PB_Processor_x86
              *vResult\vt   = #VT_I4
              *vResult\lVal = GetRuntimeInteger(name)
            CompilerElse
              *vResult\vt    = #VT_I8
              *vResult\llVal = GetRuntimeInteger(name)
            CompilerEndIf
            ProcedureReturn #S_OK
          Else
            ProcedureReturn #DISP_E_BADINDEX
          EndIf
         
        ElseIf Flags & #DISPATCH_PROPERTYPUT
          ; Hier werden die Anzahl der Parameter überprüft
          If cArgs <> 2
            ProcedureReturn #DISP_E_BADPARAMCOUNT
          EndIf
          ; Hier werden die Typen der Parameter überprüft
          If CheckVT(*vArgs\Value[1], #VT_BSTR)
            ProcedureReturn #DISP_E_BADVARTYPE
          EndIf
          name = VT_STR(*vArgs\Value[1])
          Debug "Runtime - Invoke() PropertyPutInteger : " + Name, #DebugLevelRuntime
          If IsRuntime(name)
            CompilerIf #PB_Compiler_Processor = #PB_Processor_x86
              If VariantChangeType_(Value, *vArgs\Value[0], 0, #VT_I4) = #S_OK
                SetRuntimeInteger(name, Value\lVal)
                VariantClear_(Value)
              EndIf
            CompilerElse
              If VariantChangeType_(Value, *vArgs\Value[0], 0, #VT_I8) = #S_OK
                SetRuntimeInteger(name, Value\llVal)
                VariantClear_(Value)
              EndIf
            CompilerEndIf
            ProcedureReturn #S_OK
          Else
            ProcedureReturn #DISP_E_BADINDEX
          EndIf
        Else
          ProcedureReturn #DISP_E_BADPARAMCOUNT
        EndIf
       
      Case #DispId_RuntimeDouble
        If Flags & #DISPATCH_PROPERTYGET
          ; Hier werden die Anzahl der Parameter überprüft
          If cArgs <> 1
            ProcedureReturn #DISP_E_BADPARAMCOUNT
          EndIf
          ; Hier werden die Typen der Parameter überprüft
          If CheckVT(*vArgs\Value[0], #VT_BSTR)
            ProcedureReturn #DISP_E_BADVARTYPE
          EndIf
          name = VT_STR(*vArgs\Value[0])
          Debug "Runtime - Invoke() PropertyGetDouble : " + name, #DebugLevelRuntime
          If IsRuntime(name)
            *vResult\vt     = #VT_R8
            *vResult\dblVal = GetRuntimeDouble(name)
            ProcedureReturn #S_OK
          Else
            ProcedureReturn #DISP_E_BADINDEX
          EndIf
         
        ElseIf Flags & #DISPATCH_PROPERTYPUT
          ; Hier werden die Anzahl der Parameter überprüft
          If cArgs <> 2
            ProcedureReturn #DISP_E_BADPARAMCOUNT
          EndIf
          ; Hier werden die Typen der Parameter überprüft
          If CheckVT(*vArgs\Value[1], #VT_BSTR)
            ProcedureReturn #DISP_E_BADVARTYPE
          EndIf
          name = VT_STR(*vArgs\Value[1])
          Debug "Runtime - Invoke() PropertyPutDouble : " + Name, #DebugLevelRuntime
          If IsRuntime(name)
            If VariantChangeType_(Value, *vArgs\Value[0], 0, #VT_R8) = #S_OK
              SetRuntimeDouble(name, Value\dblVal)
              VariantClear_(Value)
            EndIf
            ProcedureReturn #S_OK
          Else
            ProcedureReturn #DISP_E_BADINDEX
          EndIf
        Else
          ProcedureReturn #DISP_E_BADPARAMCOUNT
        EndIf
       
      Case #DispId_RuntimeString
        If Flags & #DISPATCH_PROPERTYGET
          ; Hier werden die Anzahl der Parameter überprüft
          If cArgs <> 1
            ProcedureReturn #DISP_E_BADPARAMCOUNT
          EndIf
          ; Hier werden die Typen der Parameter überprüft
          If CheckVT(*vArgs\Value[0], #VT_BSTR)
            ProcedureReturn #DISP_E_BADVARTYPE
          EndIf
          name = VT_STR(*vArgs\Value[0])
          Debug "Runtime - Invoke() PropertyGetString : " + name, #DebugLevelRuntime
          If IsRuntime(name)
            *vResult\vt      = #VT_BSTR
            *vResult\bstrVal = SysAllocString_(GetRuntimeString(name))
            ProcedureReturn #S_OK
          Else
            ProcedureReturn #DISP_E_BADINDEX
          EndIf
         
        ElseIf Flags & #DISPATCH_PROPERTYPUT
          ; Hier werden die Anzahl der Parameter überprüft
          If cArgs <> 2
            ProcedureReturn #DISP_E_BADPARAMCOUNT
          EndIf
          ; Hier werden die Typen der Parameter überprüft
          If CheckVT(*vArgs\Value[1], #VT_BSTR)
            ProcedureReturn #DISP_E_BADVARTYPE
          EndIf
          name = VT_STR(*vArgs\Value[1])
          Debug "Runtime - Invoke() PropertyPutString : " + name, #DebugLevelRuntime
          If IsRuntime(name)
            If VariantChangeType_(Value, *vArgs\Value[0], 0, #VT_BSTR) = #S_OK
              SetRuntimeString(name, PeekS(Value\bstrVal))
              VariantClear_(Value)
            EndIf
            ProcedureReturn #S_OK
          Else
            ProcedureReturn #DISP_E_BADINDEX
          EndIf
        Else
          ProcedureReturn #DISP_E_BADPARAMCOUNT
        EndIf
       
      Case #DispId_RuntimeSleep
        ; Hier werden die Anzahl der Parameter überprüft
        If *Dispparams\cArgs <> 1
          ProcedureReturn #DISP_E_BADPARAMCOUNT
        EndIf
        ; Hier werden die Typen der Parameter überprüft
        If VariantChangeType_(Value, *vArgs\Value[0], 0, #VT_I4) = #S_OK
          t1 = Value\lVal
          VariantClear_(Value)
        Else
          ProcedureReturn #DISP_E_BADVARTYPE
        EndIf
        Debug "Runtime - Invoke() Sleep : " + t1, #DebugLevelRuntime
        If t1 > 60000
          t1 = 60000
        EndIf
        Delay(t1)
        ProcedureReturn #S_OK
       
      Case #DispId_RuntimeTrace
        ; Hier werden die Anzahl der Parameter überprüft
        If *Dispparams\cArgs <> 1
          ProcedureReturn #DISP_E_BADPARAMCOUNT
        EndIf
        ; Hier werden die Typen der Parameter überprüft
        name = VT_STR(*vArgs\Value[0])
        If #UseActiveScriptDebugView
          OutputDebugString_(name)
        EndIf
        Debug "Runtime - Invoke() Trace : " + name, #DebugLevelRuntime
        ProcedureReturn #S_OK
       
      Default
        ProcedureReturn #DISP_E_MEMBERNOTFOUND
       
    EndSelect
   
  EndProcedure
 
  ; -----------------------------------------------------------------------------------
 
  Procedure New()
    Protected *this.objRuntime
   
    *this = AllocateStructure(objRuntime)
    If *this = 0
      Debug "New ActiveRuntime - Out Of Memory", #DebugLevelRuntime
      ProcedureReturn 0
    Else
      *this\VTABLE = ?VT_Runtime
      *this\cntRef = 1
      ProcedureReturn *this
    EndIf
   
  EndProcedure
 
  ; -----------------------------------------------------------------------------------
 
  DataSection
    VT_Runtime:
    Data.i @QueryInterface()
    Data.i @AddRef()
    Data.i @Release()
    Data.i @GetTypeInfoCount()
    Data.i @GetTypeInfo()
    Data.i @GetIDsOfNames()
    Data.i @Invoke()
  EndDataSection
 
  ; -----------------------------------------------------------------------------------
 
EndModule

; ***************************************************************************************

;- Module ActiveScriptInterruptPull

DeclareModule ActiveScriptInterruptPull
 
  Declare New()
 
EndDeclareModule

; ---

Module ActiveScriptInterruptPull
 
  EnableExplicit
 
  UseModule ActiveScriptCommon
 
  DebugLevel #DebugLevel
 
  ; -----------------------------------------------------------------------------------
 
  Structure objSiteInterruptPoll
    *VTable
    cntRef.i
    *IID.IID
    *Me.cSH
    time.i
  EndStructure
 
  ; -----------------------------------------------------------------------------------
 
  Procedure QueryInterface(*This.objSiteInterruptPoll, *iid.IID, *Object.Integer)
   
    ; Standardzuweisungen auf eigenes Objekt
    If CompareMemory(*iid, ?IID_IUnknown, 16)
      Debug "SiteInterruptPoll - QueryInterface() : IUnknown -> Ok", #DebugLevelActiveScript
      *Object\i = *This
      *This\cntRef + 1
      ProcedureReturn #S_OK
    ElseIf CompareMemory(*iid, ?IID_IDispatch, 16)
      Debug "SiteInterruptPoll - QueryInterface() : IDispatch -> Ok", #DebugLevelActiveScript
      *Object\i = *This
      *This\cntRef + 1
      ProcedureReturn #S_OK
    ElseIf CompareMemory(*iid, ?IID_IDispatchEx, 16)
      Debug "SiteInterruptPoll - QueryInterface() : IDispatchEx -> No Interface", #DebugLevelActiveScript
      *Object\i = 0
      ProcedureReturn #E_NOINTERFACE
    Else
      Debug "SiteInterruptPoll - QueryInterface() : No Interface", #DebugLevelActiveScript
      *Object\i = 0
      ProcedureReturn #E_NOINTERFACE
    EndIf
   
  EndProcedure
 
  ; -----------------------------------------------------------------------------------
 
  Procedure AddRef(*This.objSiteInterruptPoll)
   
    Debug "SiteInterruptPoll - AddRef() :  Refcount = " + Str(*This\cntRef) + " > " + Str(*This\cntRef + 1), #DebugLevelActiveScript
    *This\cntRef + 1
    ProcedureReturn *This\cntRef
   
  EndProcedure
 
  ; -----------------------------------------------------------------------------------
 
  Procedure Release(*This.objSiteInterruptPoll)
   
    Debug "SiteInterruptPoll - Release() : Refcount = " + Str(*This\cntRef) + " > " + Str(*This\cntRef - 1), #DebugLevelActiveScript
    *This\cntRef - 1
    If *This\cntRef < 1
      FreeStructure(*This)
      ProcedureReturn 0
    Else
      ProcedureReturn *This\cntRef
    EndIf
  EndProcedure
 
  ; -----------------------------------------------------------------------------------
 
  Procedure QueryContinue(*This.objSiteInterruptPoll)
   
    Debug "SiteInterruptPoll - QueryContinue()", #DebugLevelActiveScript
    ; Abfrage ob Script fortgesetzt werden soll
    Select MessageRequester("ActiveScript", "Scriptcodes stopped." + #CRLF$ + "Continue Scriptcode?", #PB_MessageRequester_YesNo)
      Case #PB_MessageRequester_Yes
        ProcedureReturn #S_OK
      Case #PB_MessageRequester_No
        ProcedureReturn #S_FALSE
    EndSelect
   
  EndProcedure
 
  ; -----------------------------------------------------------------------------------
 
  Procedure New()
    Protected *this.objSiteInterruptPoll
   
    *this = AllocateStructure(objSiteInterruptPoll)
    If *this = 0
      Debug "New SiteInterruptPoll - Out Of Memory", #DebugLevelActiveScript
      ProcedureReturn 0
    Else
      *this\VTABLE = ?VT_SiteInterruptPoll
      *this\IID    = ?IID_IActiveScriptSiteInterruptPoll
      *this\cntRef = 1
      *this\Me     = 0
      ProcedureReturn *this
    EndIf
   
  EndProcedure
 
  ; -----------------------------------------------------------------------------------
 
  DataSection
    VT_SiteInterruptPoll:
    Data.i @QueryInterface()
    Data.i @AddRef()
    Data.i @Release()
    Data.i @QueryContinue()
  EndDataSection
 
  ; -----------------------------------------------------------------------------------
 
EndModule

; ***************************************************************************************

;- Module ActiveScriptSiteWindow

DeclareModule ActiveScriptSiteWindow
 
  Declare New()
 
EndDeclareModule

; ---

Module ActiveScriptSiteWindow
 
  EnableExplicit
 
  UseModule ActiveScriptCommon
 
  DebugLevel #DebugLevel
 
  ; -----------------------------------------------------------------------------------
 
  Structure objActiveScriptSiteWindow
    *VTable
    cntRef.i
  EndStructure
 
  ; -----------------------------------------------------------------------------------
 
  Procedure QueryInterface(*This.objActiveScriptSiteWindow, *iid.IID, *Object.Integer)
   
    If CompareMemory(*iid, ?IID_IUnknown, 16)
      ; Standardzuweisungen auf eigenes Objekt
      Debug "ActiveScriptSiteWindow - QueryInterface() : IUnknown -> Ok", #DebugLevelActiveScript
      *Object\i = *This
      ProcedureReturn #S_OK
    ElseIf CompareMemory(*iid, ?IID_IActiveScriptSiteWindow, 16)
      ; Standardzuweisungen auf eigenes Objekt
      Debug "ActiveScriptSiteWindow - QueryInterface() : IActiveScriptSiteWindow -> Ok", #DebugLevelActiveScript
      *Object\i = *This
      ProcedureReturn #S_OK
    Else
      ; Unbekanntes Interface
      Debug "ActiveScriptSiteWindow - QueryInterface() : No Interface", #DebugLevelActiveScript
      *Object\i = 0
      ProcedureReturn #E_NOINTERFACE
    EndIf
   
  EndProcedure
 
  ; -----------------------------------------------------------------------------------
 
  Procedure AddRef(*This.objActiveScriptSiteWindow)
   
    Debug "ActiveScriptSiteWindow - AddRef() :  Refcount = " + Str(*This\cntRef) + " > " + Str(*This\cntRef + 1), #DebugLevelActiveScript
    *This\cntRef + 1
    ProcedureReturn *This\cntRef
   
  EndProcedure
 
  ; -----------------------------------------------------------------------------------
 
  Procedure Release(*This.objActiveScriptSiteWindow)
   
    Debug "ActiveScriptSiteWindow - Release() : Refcount = " + Str(*This\cntRef) + " > " + Str(*This\cntRef - 1), #DebugLevelActiveScript
    *This\cntRef - 1
    If *This\cntRef < 1
      FreeStructure(*This)
      ProcedureReturn 0
    Else
      ProcedureReturn *This\cntRef
    EndIf
  EndProcedure
 
  ; -----------------------------------------------------------------------------------
 
  Procedure GetWindow(*this.objActiveScriptSiteWindow, *WindowID.Integer)
    Debug "ActiveScriptSiteWindow - GetWindow()", #DebugLevelActiveScript
    *WindowID\i = 0
    ProcedureReturn #E_NOTIMPL
  EndProcedure
 
  ; -----------------------------------------------------------------------------------
 
  Procedure EnableModless(*this.objActiveScriptSiteWindow, fEnable)
    Debug "ActiveScriptSiteWindow - EnableModless()", #DebugLevelActiveScript
    ProcedureReturn #S_OK
  EndProcedure
 
  ; -----------------------------------------------------------------------------------
 
  Procedure New()
    Protected *this.objActiveScriptSiteWindow
   
    *this = AllocateStructure(objActiveScriptSiteWindow)
    If *this = 0
      Debug "New ActiveScriptSiteWindow - Out Of Memory", #DebugLevelActiveScript
      ProcedureReturn 0
    Else
      *this\VTABLE = ?VT_ActiveScriptSiteWindow
      *this\cntRef = 1
      ProcedureReturn *this
    EndIf
   
  EndProcedure
 
  ; -----------------------------------------------------------------------------------
 
  DataSection
    VT_ActiveScriptSiteWindow:
    Data.i @QueryInterface()
    Data.i @AddRef()
    Data.i @Release()
    Data.i @GetWindow()
    Data.i @EnableModless()
  EndDataSection
 
  ; -----------------------------------------------------------------------------------
 
EndModule

; ***************************************************************************************

;- Module ActiveScriptSite

DeclareModule ActiveScriptSite
 
  Declare New(*Parent)
 
EndDeclareModule

; ---

Module ActiveScriptSite
 
  EnableExplicit
 
  UseModule ActiveScriptCommon
 
  DebugLevel #DebugLevel
 
  ; -----------------------------------------------------------------------------------
 
  Structure objActiveScriptSite
    *VTABLE
    cntRef.i
    *Parent.objActiveScriptControl
    *InterruptPoll.IActiveScriptSiteInterruptPoll
    *ActiveScriptSiteWindow.IActiveScriptSiteWindow
  EndStructure
 
  ; -----------------------------------------------------------------------------------
 
  Procedure QueryInterface(*this.objActiveScriptSite, *iid.IID, *Object.Integer)
   
    If CompareMemory(*iid, ?IID_IUnknown, 16)
      ; IUnknown
      Debug "ActiveScriptSite - QueryInterface() : IUnknown -> Ok", #DebugLevelActiveScript
      *Object\i = *this
      ProcedureReturn #S_OK
     
    ElseIf CompareMemory(*iid, ?IID_IActiveScriptSite, 16)
      ; ActiveScriptSite
      Debug "ActiveScriptSite - QueryInterface() : IActiveScriptSite -> Ok", #DebugLevelActiveScript
      *Object\i = *this
      ProcedureReturn #S_OK
     
    ElseIf CompareMemory(*iid, ?IID_IActiveScriptSiteWindow, 16)
      ; ActiveScriptSiteWindow - Objekt zuweisen
      If *this\ActiveScriptSiteWindow = 0
        *this\ActiveScriptSiteWindow = ActiveScriptSiteWindow::New()
      EndIf
      If *this\ActiveScriptSiteWindow
        Debug "ActiveScriptSite - QueryInterface() : IActiveScriptSiteWindow -> Ok", #DebugLevelActiveScript
        *this\ActiveScriptSiteWindow\AddRef()
        *Object\i = *this\ActiveScriptSiteWindow
        ProcedureReturn #S_OK
      Else
        Debug "ActiveScriptSite - QueryInterface() : IActiveScriptSiteWindow -> Out of Memory", #DebugLevelActiveScript
        *Object\i = 0
        ProcedureReturn #E_OUTOFMEMORY
      EndIf
     
    ElseIf CompareMemory(*iid, ?IID_IActiveScriptSiteUIControl, 16)
      ; ActiveScriptSiteUIControl
      Debug "ActiveScriptSite - QueryInterface() : IActiveScriptSiteUIControl -> No Interface", #DebugLevelActiveScript
      *Object\i = 0
      ProcedureReturn #E_NOINTERFACE
     
    ElseIf CompareMemory(*iid, ?IID_IActiveScriptSiteInterruptPoll, 16)
      If Not #UseActiveScriptInterruptPull
        Debug "ActiveScriptSite - QueryInterface() : IActiveScriptSiteInterruptPoll -> No Interface", #DebugLevelActiveScript
        ProcedureReturn #E_NOINTERFACE
      EndIf
      ; SiteInterruptPoll - Objekt zuweisen
      If *this\InterruptPoll = 0
        *this\InterruptPoll = ActiveScriptInterruptPull::New()
      EndIf
      If *this\InterruptPoll
        Debug "ActiveScriptSite - QueryInterface() : IActiveScriptSiteInterruptPoll -> Ok", #DebugLevelActiveScript
        *this\InterruptPoll\AddRef()
        *Object\i = *this\InterruptPoll
        ProcedureReturn #S_OK
      Else
        Debug "ActiveScriptSite - QueryInterface() : IActiveScriptSiteInterruptPoll -> Out of Memory", #DebugLevelActiveScript
        *Object\i = 0
        ProcedureReturn #E_OUTOFMEMORY
      EndIf
     
    ElseIf CompareMemory(*iid, ?IID_IActiveScriptSiteDebug, 16)
      ; ActiveScriptSiteDebug
      Debug "ActiveScriptSite - QueryInterface() : IActiveScriptSiteDebug -> No Interface", #DebugLevelActiveScript
      *Object\i = 0
      ProcedureReturn #E_NOINTERFACE
     
    Else
      Debug "ActiveScriptSite - QueryInterface() : IID " + GetGuidString(*iid) + " -> No Interface", #DebugLevelActiveScript
      *Object\i = 0
      ProcedureReturn #E_NOINTERFACE
    EndIf
   
  EndProcedure
 
  ; -----------------------------------------------------------------------------------
 
  Procedure AddRef(*this.objActiveScriptSite)
   
    Debug "ActiveScriptSite - AddRef() : Refcount " + Str(*This\cntRef) + " > " + Str(*This\cntRef + 1), #DebugLevelActiveScript
    *this\cntRef + 1
    ProcedureReturn *this\cntRef
   
  EndProcedure
 
  ; -----------------------------------------------------------------------------------
 
  Procedure Release(*this.objActiveScriptSite)
    Protected hr
    Debug "ActiveScriptSite - Release() : Refcount = " + Str(*This\cntRef) + " > " + Str(*This\cntRef - 1), #DebugLevelActiveScript
    *this\cntRef - 1
    If *this\cntRef < 1
      If *this\InterruptPoll
        Repeat
          hr = *this\InterruptPoll\Release()
        Until hr = 0
      EndIf
      If *this\ActiveScriptSiteWindow
        Repeat
          hr = *this\ActiveScriptSiteWindow\Release()
        Until hr = 0
      EndIf
      FreeStructure(*this)
      ProcedureReturn 0
    Else
      ProcedureReturn *this\cntRef
    EndIf
   
  EndProcedure
 
  ; -----------------------------------------------------------------------------------
 
  Procedure GetLCID(*this.objActiveScriptSite, *LCID.Long)
    Protected sLCID.s{6}
   
    ;Language Id auslesen
    GetLocaleInfo_(#LOCALE_USER_DEFAULT, #LOCALE_ILANGUAGE, @sLCID, 6)
    *LCID\l = Val(sLCID)
    ProcedureReturn #S_OK
   
  EndProcedure
 
  ; -----------------------------------------------------------------------------------
 
  Procedure GetItemInfo(*this.objActiveScriptSite, SpaceName.s, ReturnMask.l, *ItemPtr.Integer, *TypeInfo.Long)
    Protected name.s
   
    Debug "ActiveScriptSite - GetItemInfo() : SpaceName = " + SpaceName, #DebugLevelActiveScript
    Select ReturnMask
      Case #SCRIPTINFO_IUNKNOWN
        name = LCase(SpaceName)
        If FindMapElement(*this\Parent\NamedItems(), name)
          *ItemPtr\i = *this\Parent\NamedItems()\Object
          ProcedureReturn #S_OK
        EndIf
      Case #SCRIPTINFO_ITYPEINFO
        ProcedureReturn #E_NOTIMPL
      Default
        ProcedureReturn #E_NOTIMPL
    EndSelect
  EndProcedure
 
  ; -----------------------------------------------------------------------------------
 
  Procedure GetDocVersionString(*this.objActiveScriptSite, *result)
    ProcedureReturn #E_NOTIMPL
  EndProcedure
 
  ; -----------------------------------------------------------------------------------
 
  Procedure OnScriptTerminate(*this.objActiveScriptSite, *pvarResult.Variant, *pexcepinfo.excepinfo)
    Debug "ActiveScriptSite - OnScriptTerminate()", #DebugLevelActiveScript
    ProcedureReturn #S_OK
  EndProcedure
 
  ; -----------------------------------------------------------------------------------
 
  Procedure OnStateChange(*this.objActiveScriptSite, ssScriptState)
    Debug "ActiveScriptSite - OnStateChange() : State = " + ssScriptState, #DebugLevelActiveScript
    ProcedureReturn #S_OK
  EndProcedure
 
  ; -----------------------------------------------------------------------------------
 
  Procedure OnScriptError(*this.objActiveScriptSite, *ScriptError.IActiveScriptError)
    Protected Title.s, Error.s, pexcepinfo.excepinfo, pbstrSourceLineText
    Protected pdwSourceContext, pulLineNumber, plCharacterPosition
   
    Debug "ActiveScriptSite - OnScriptError()", #DebugLevelActiveScript
   
    *ScriptError\GetExceptionInfo(@pexcepinfo)
    *ScriptError\GetSourcePosition(@pdwSourceContext, @pulLineNumber, @plCharacterPosition)
    *ScriptError\GetSourceLineText(@pbstrSourceLineText)
    *ScriptError\Release()
   
    Title = "ActiveScriptSite - OnScriptError"
    Error = ""
    If pexcepinfo\bstrSource
      Error + PeekS(pexcepinfo\bstrSource) + #LF$ + #LF$
      SysFreeString_(pexcepinfo\bstrSource)
    EndIf
    If pexcepinfo\bstrDescription
      Error + PeekS(pexcepinfo\bstrDescription) + #LF$
      SysFreeString_(pexcepinfo\bstrDescription)
    EndIf
    Error + "Line: " + pulLineNumber + " Column: " + plCharacterPosition + #LF$ + #LF$
    If pbstrSourceLineText
      Error + "Code: " + PeekS(pbstrSourceLineText)
      SysFreeString_(pbstrSourceLineText)
    EndIf
    If pexcepinfo\bstrHelpFile
      SysFreeString_(pexcepinfo\bstrHelpFile)
    EndIf
   
    MessageRequester(Title, Error, #PB_MessageRequester_Error)
   
    ProcedureReturn #S_OK
  EndProcedure
 
  ; -----------------------------------------------------------------------------------
 
  Procedure OnEnterScript(*this.objActiveScriptSite)
    Debug "ActiveScriptSite - OnEnterScript()", #DebugLevelActiveScript
    ProcedureReturn #S_OK
  EndProcedure
 
  ; -----------------------------------------------------------------------------------
 
  Procedure OnLeaveScript(*this.objActiveScriptSite)
    Debug "ActiveScriptSite - OnLeaveScript()", #DebugLevelActiveScript
    ProcedureReturn #S_OK
  EndProcedure
 
  ; -----------------------------------------------------------------------------------
 
  Procedure New(*ParentControl)
    Protected *this.objActiveScriptSite
   
    *this = AllocateStructure(objActiveScriptSite)
    If *this = 0
      Debug "ActiveScriptSite - Out Of Memory", #DebugLevelActiveScript
      ProcedureReturn 0
    Else
      *this\VTABLE = ?VT_ActiveScriptSite
      *this\cntRef = 1
      *this\Parent = *ParentControl
      ProcedureReturn *this
    EndIf
   
  EndProcedure
 
  ; -----------------------------------------------------------------------------------
 
  DataSection
    VT_ActiveScriptSite:
    Data.i @QueryInterface()
    Data.i @AddRef()
    Data.i @Release()
    Data.i @GetLCID()
    Data.i @GetItemInfo()
    Data.i @GetDocVersionString()
    Data.i @OnScriptTerminate()
    Data.i @OnStateChange()
    Data.i @OnScriptError()
    Data.i @OnEnterScript()
    Data.i @OnLeaveScript()
  EndDataSection
 
  ; -----------------------------------------------------------------------------------
 
EndModule

; ***************************************************************************************

;- Module ActiveScript

DeclareModule ActiveScript
 
  #SCRIPTTEXT_ISVISIBLE      = 2
  #SCRIPTTEXT_ISEXPRESSION   = 32
  #SCRIPTTEXT_ISPERSISTENT   = 64
 
  Declare NewActiveScript(Script.s = "VBScript")
  Declare FreeActiveScript(*Control)
  Declare ParseScriptText(*Control, Code.s, dwFlags = #SCRIPTTEXT_ISPERSISTENT | #SCRIPTTEXT_ISVISIBLE)
  Declare AddNamedObject(*Control, SpaceName.s, *Object.IDispatch)
 
EndDeclareModule

; ---

Module ActiveScript
 
  EnableExplicit
 
  UseModule ActiveScriptCommon
 
  DebugLevel #DebugLevel
 
  ; -----------------------------------------------------------------------------------
 
  Global ClsId.GUID
  Global ExcInfo.EXCEPINFO
  Global LastError
 
  ; -----------------------------------------------------------------------------------
 
  Procedure NewActiveScript(Script.s = "VBScript")
    Protected hr, *Control.objActiveScriptControl
   
    With *Control
      *Control = AllocateStructure(objActiveScriptControl)
      If *Control = 0
        ProcedureReturn 0
      EndIf
     
      hr = CoInitialize_(0)
      If hr <> #S_OK And hr <> #S_FALSE
        LastError = hr
        FreeStructure(*Control)
        ProcedureReturn 0
      EndIf
     
      ; KlassenId suchen
      hr = CLSIDFromProgID_(@Script, @ClsId)
      If hr <> #S_OK
        LastError = hr
        FreeStructure(*Control)
        ProcedureReturn 0
      EndIf
     
      ; Instanz der Scriptengine erstellen
      hr = CoCreateInstance_(@ClsId, 0, 1, ?IID_IActiveScript, @\ActiveScript)
      If hr <> #S_OK
        LastError = hr
        FreeStructure(*Control)
        ProcedureReturn 0
      EndIf
     
      \ActiveScript\AddRef()
     
      ; Parseinterface der Scriptengine suchen
      hr = \ActiveScript\QueryInterface(?IID_IActiveScriptParse, @\ActiveScriptParse)
      If hr <> #S_OK
        LastError = hr
        \ActiveScript\Release()
        FreeStructure(*Control)
        ProcedureReturn 0
      EndIf
     
      ; Object für Scriptsite erstellen
      \ActiveScriptSite = ActiveScriptSite::New(*Control)
      If \ActiveScriptSite
        \ActiveScriptSite\AddRef()
      Else
        LastError = #E_UNEXPECTED
        \ActiveScriptParse\Release()
        \ActiveScript\Release()
        FreeStructure(*Control)
        ProcedureReturn 0
      EndIf
     
      ; Scriptsite zuweisen
      hr = \ActiveScript\SetScriptSite(\ActiveScriptSite)
      If hr <> #S_OK
        LastError = hr
        \ActiveScriptSite\Release()
        \ActiveScriptParse\Release()
        \ActiveScript\Release()
        FreeStructure(*Control)
        ProcedureReturn 0
      EndIf
     
      ; Parseinterface initialisieren
      hr = \ActiveScriptParse\InitNew()
      If hr <> #S_OK
        LastError = hr
        \ActiveScriptSite\Release()
        \ActiveScriptParse\Release()
        \ActiveScript\Release()
        FreeStructure(*Control)
        ProcedureReturn 0
      EndIf
     
      ; Script Engine Starten
      hr = \ActiveScript\SetScriptState(#SCRIPTSTATE_STARTED)
      If hr <> #S_OK
        LastError = hr
        \ActiveScriptSite\Release()
        \ActiveScriptParse\Release()
        \ActiveScript\Release()
        FreeStructure(*Control)
        ProcedureReturn 0
      EndIf
     
      ; Script Engine Verbinden
      hr = \ActiveScript\SetScriptState(#SCRIPTSTATE_CONNECTED)
      If hr <> #S_OK
        LastError = hr
        \ActiveScriptSite\Release()
        \ActiveScriptParse\Release()
        \ActiveScript\Release()
        FreeStructure(*Control)
        ProcedureReturn 0
      EndIf
     
      ; Added PB Runtime variables
      AddNamedObject(*Control, "Runtime", ActiveScriptRuntime::New())
     
      ProcedureReturn *Control
    EndWith
   
  EndProcedure
 
  ; -----------------------------------------------------------------------------------
 
  Procedure FreeActiveScript(*Control.objActiveScriptControl)
    Protected hr
   
    With *Control
      If \ActiveScriptParse
        \ActiveScriptParse\AddRef()
        Repeat
          hr = \ActiveScriptParse\Release()
        Until hr <= 2
      EndIf
      If \ActiveScriptSite
        Repeat
          hr = \ActiveScriptSite\Release()
        Until hr = 0
      EndIf
      If \ActiveScript
        \ActiveScript\AddRef()
        Repeat
          hr =  \ActiveScript\Release()
        Until hr <= 1
      EndIf
      ForEach \NamedItems()
        Repeat
          hr = \NamedItems()\Object\Release()
        Until hr = 0
      Next
      FreeStructure(*Control)
    EndWith
  EndProcedure
 
  ; -----------------------------------------------------------------------------------
 
  Procedure ParseScriptText(*Control.objActiveScriptControl, Code.s, dwFlags = #SCRIPTTEXT_ISPERSISTENT | #SCRIPTTEXT_ISVISIBLE)
    Protected hr
    With *Control
      If \ActiveScriptParse
        hr = \ActiveScriptParse\ParseScriptText(@Code, 0, 0, 0, 0, 0, dwFlags, 0, @ExcInfo)
        \ActiveScriptParse\Release()
        ProcedureReturn hr
      Else
        ProcedureReturn #S_FALSE
      EndIf
    EndWith
  EndProcedure
 
  ; -----------------------------------------------------------------------------------
 
  Procedure AddNamedObject(*Control.objActiveScriptControl, SpaceName.s, *Object.IDispatch)
    Protected hr, name.s
    With *Control
      If \ActiveScript
        hr = \ActiveScript\AddNamedItem(@SpaceName, #SCRIPTITEM_ISVISIBLE)
        If hr = #S_OK
          name = LCase(SpaceName)
          AddMapElement(\NamedItems(), name)
          \NamedItems()\Name   = SpaceName
          \NamedItems()\Object = *Object
          \NamedItems()\type   = #SCRIPTITEM_ISVISIBLE
        EndIf
      Else
        hr = #S_FALSE
      EndIf
    EndWith
    ProcedureReturn hr
  EndProcedure
 
  ; -----------------------------------------------------------------------------------
 
EndModule

;- End Module

; ***************************************************************************************

_________________
My Projects ThreadToGUI / OOP-BaseClass / OOP-BaseClassDispatch / EventDesigner V3
PB v3.30 / v5.70 - OS Mac Mini OSX 10.xx - VM Window Pro / Linux Ubuntu
Downloads on my Webspace


Last edited by mk-soft on Sat Jun 01, 2019 6:39 pm, edited 29 times in total.

Top
 Profile  
Reply with quote  
 Post subject: Re: Module ActiveScript for VB-Script with PB-Runtime Variab
PostPosted: Sun Sep 16, 2018 1:07 am 
Offline
Addict
Addict
User avatar

Joined: Fri May 12, 2006 6:51 pm
Posts: 2020
Location: Germany
SmartTags are of type Variant to allow an exchange of all types of variables with Purebasic, such as arrays, objects, etc.

Update v1.04
- Optimize debug output

Update v1.05
- Added ClearSmartTags(TagName)

To avoid memory leaks, the SmartTag must be cleaned up after use,
because with strings or arrays in the SmartTag only the reference to the memory is stored.

Update v2.01
- SmartTags now ThreadSafe
- Added LockSmartTags() and UnlockSmartTags()

Update v2.03
- Bugfix and optimize code

AddON SmartTags
Code:
;-TOP

; Comment   : Modul ActiveScript AddOn SmartTags of type Variant (Case Sensisive)
; Author    : mk-soft
; Version   : v2.03
; Create    : 15.09.2018
; Update    : 30.5.2019
; Link      : https://www.purebasic.fr/english/viewtopic.php?f=12&t=71399#p527089

; OS        : Windows

; ***************************************************************************************

XIncludeFile "Modul_ActiveScript.pb"

DeclareModule ActiveSmartTags
 
  Global NewMap SmartTags.VARIANT()
 
  Declare NewSmartTags()
  Declare ClearSmartTags(Tag.s)
  Declare LockSmartTags()
  Declare UnlockSmartTags()
 
EndDeclareModule

Module ActiveSmartTags
 
  EnableExplicit
 
  UseModule ActiveScriptCommon
 
  ; Define Debuglevel
  #DebugLevelSmartags = 2
 
  DebugLevel #DebugLevel
 
  ; -----------------------------------------------------------------------------------
 
  Enumeration 1
    #DispId_Value
  EndEnumeration
 
  Structure objSmartTags
    *VTABLE
    cntRef.i
  EndStructure
 
  Structure udtArgs
    Value.Variant[0]
  EndStructure
 
  ; -----------------------------------------------------------------------------------
 
  Procedure InitModule()
    Global MutexSmartTags = CreateMutex()
  EndProcedure : InitModule()
 
  ; -----------------------------------------------------------------------------------
 
  Procedure CheckVT(*var.VARIANT, Type)
    If (*var\vt & #VT_TYPEMASK) <> Type
      ProcedureReturn #DISP_E_BADVARTYPE
    Else
      ProcedureReturn #S_OK
    EndIf
  EndProcedure
 
  ; -----------------------------------------------------------------------------------
 
  Procedure.s VT_STR(*Var.Variant)
    Protected hr, result.s, VarDest.Variant
    If *Var
      If *Var\vt = #VT_BSTR
        result = PeekS(*Var\bstrVal, #PB_Any, #PB_Unicode)
        ProcedureReturn result
      Else
        hr = VariantChangeType_(VarDest, *Var, 0, #VT_BSTR)
        If hr = #S_OK
          result = PeekS(VarDest\bstrVal, #PB_Any, #PB_Unicode)
          VariantClear_(VarDest)
          ProcedureReturn result
        Else
          ProcedureReturn ""
        EndIf
      EndIf
    EndIf
  EndProcedure
 
  ; -----------------------------------------------------------------------------------
 
  Procedure LockSmartTags()
    LockMutex(MutexSmartTags)
    PushMapPosition(SmartTags())
  EndProcedure
 
  Procedure UnlockSmartTags()
    PopMapPosition(SmartTags())
    UnlockMutex(MutexSmartTags)
  EndProcedure
  ; -----------------------------------------------------------------------------------
 
  ; Begin Interfaces IDispatch
 
  Procedure QueryInterface(*This.objSmartTags, *iid.IID, *Object.Integer)
   
    ; Standardzuweisungen auf eigenes Objekt
    If CompareMemory(*iid, ?IID_IUnknown, 16)
      Debug "SmartTags - QueryInterface() : IUnknown -> Ok", #DebugLevelSmartags
      *Object\i = *This
      *This\cntRef + 1
      ProcedureReturn #S_OK
    ElseIf CompareMemory(*iid, ?IID_IDispatch, 16)
      Debug "SmartTags - QueryInterface() : IDispatch -> Ok", #DebugLevelSmartags
      *Object\i = *This
      *This\cntRef + 1
      ProcedureReturn #S_OK
    ElseIf CompareMemory(*iid, ?IID_IDispatchEx, 16)
      Debug "SmartTags - QueryInterface() : IDispatchEx -> No Interface", #DebugLevelSmartags
      *Object\i = 0
      ProcedureReturn #E_NOINTERFACE
    Else
      Debug "SmartTags - QueryInterface() No Interface", #DebugLevelSmartags
      *Object\i = 0
      ProcedureReturn #E_NOINTERFACE
    EndIf
   
  EndProcedure
 
  ; -----------------------------------------------------------------------------------
 
  Procedure AddRef(*This.objSmartTags)
   
    Debug "SmartTags - AddRef() :  Refcount = " + Str(*This\cntRef) + " > " + Str(*This\cntRef+1), #DebugLevelSmartags
    *This\cntRef + 1
    ProcedureReturn *This\cntRef
   
  EndProcedure
 
  ; -----------------------------------------------------------------------------------
 
  Procedure Release(*This.objSmartTags)
   
    Debug "SmartTags - Release() : Refcount = " + Str(*This\cntRef) + " > " + Str(*This\cntRef-1), #DebugLevelSmartags
    *This\cntRef - 1
    If *This\cntRef < 1
      FreeStructure(*This)
      ProcedureReturn 0
    Else
      ProcedureReturn *This\cntRef
    EndIf
  EndProcedure
 
  ; -----------------------------------------------------------------------------------
 
  Procedure GetTypeInfoCount(*This.objSmartTags, *CntTypeInfo.Long)
    *CntTypeInfo\l = 0
    ProcedureReturn #S_OK
  EndProcedure
 
  ; -----------------------------------------------------------------------------------
 
  Procedure GetTypeInfo(*This.objSmartTags, TypeInfo, LocalId, *ppTypeInfo.Integer)
    ProcedureReturn #E_NOTIMPL
  EndProcedure
 
  ; -----------------------------------------------------------------------------------
 
  Procedure GetIDsOfNames(*This.objSmartTags, *iid.IID, *Name.String, cntNames, lcid, *DispId.Long)
   
    Protected Name.s
   
    Name = LCase(*Name\s)
   
    ; Hier die Funktionsnamen auf DispId auflösen
    Select name
      Case "value" 
        *DispId\l = #DispId_Value
       
      Default
        Debug "SmartTags - GetIDsOfNames() : Member Not Found", #DebugLevelSmartags
        ProcedureReturn #DISP_E_MEMBERNOTFOUND
       
    EndSelect
   
    Debug "SmartTags - GetIDsOfNames() : Name = " + Name + " -> DispId = " + *DispId\l, #DebugLevelSmartags
   
    ProcedureReturn #S_OK
   
  EndProcedure
 
  ; -----------------------------------------------------------------------------------
 
  Procedure Invoke(*This.objSmartTags, DispId.l, *iid.IID, lcid.l, Flags.w, *DispParams.DISPPARAMS, *vResult.VARIANT, *ExcepInfo.EXCEPINFO, *ArgErr.Integer)
   
    Protected *vArgs.udtArgs, tagname.s
   
    *vArgs = *DispParams\rgvarg
   
    ; Hier werden die Funktionen aufgerufen
    ; Mit den Flags kann man den Type PropertyGet oder PropertyPut unterscheiden 
   
    Select DispId
      Case 0, #DispId_Value
        ; Funktion für Get aufrufen
        If Flags & #DISPATCH_PROPERTYGET
          ; Hier werden die Anzahl der Parameter überprüft
          If *Dispparams\cArgs <> 1
            ProcedureReturn #DISP_E_BADPARAMCOUNT
          EndIf
          ; Hier werden die Typen der Parameter überprüft
          If CheckVT(*vArgs\Value[0], #VT_BSTR)
            ProcedureReturn #DISP_E_BADVARTYPE
          EndIf
          ;
          tagname = VT_STR(*vArgs\Value[0])
          Debug "SmartTags - Invoke() PropertyGet : " + tagname, #DebugLevelSmartags
          LockSmartTags()
          If FindMapElement(SmartTags(), tagname)
            VariantCopy_(*vResult, @SmartTags())
            UnlockSmartTags()
            ProcedureReturn #S_OK
          Else
            UnlockSmartTags()
            ProcedureReturn #S_FALSE
          EndIf
         
          ; Funktion für Put aufrufen
        ElseIf Flags & #DISPATCH_PROPERTYPUT
          ; Hier werden die Anzahl der Parameter überprüft
          If *Dispparams\cArgs <> 2
            ProcedureReturn #DISP_E_BADPARAMCOUNT
          EndIf
          ; Hier werden die Typen der Parameter überprüft
          If CheckVT(*vArgs\Value[1], #VT_BSTR)
            ProcedureReturn #DISP_E_BADVARTYPE
          EndIf
          tagname = VT_STR(*vArgs\Value[1])
          Debug "SmartTags - Invoke() PropertyPut : " + tagname, #DebugLevelSmartags
          LockSmartTags()
          If FindMapElement(SmartTags(), tagname)
            VariantClear_(@SmartTags())
            VariantCopy_(@SmartTags(), *vArgs\Value[0])
            UnlockSmartTags()
            ProcedureReturn #S_OK
          Else
            If AddMapElement(SmartTags(), tagname)
              VariantCopy_(@SmartTags(), *vArgs\Value[0])
              UnlockSmartTags()
              ProcedureReturn #S_OK
            Else
              UnlockSmartTags()
              ProcedureReturn #E_OUTOFMEMORY
            EndIf
          EndIf
         
        Else
          ; Funktion wurde ohne Get oder Put aufgerufen
          ProcedureReturn #DISP_E_BADPARAMCOUNT
        EndIf
       
      Default
        ProcedureReturn #DISP_E_MEMBERNOTFOUND
       
    EndSelect
   
  EndProcedure
 
  ; -----------------------------------------------------------------------------------
 
  Procedure NewSmartTags()
    Protected *this.objSmartTags
   
    *this = AllocateStructure(objSmartTags)
    If *this = 0
      Debug "ActiveSmartTags - Out Of Memory", #DebugLevelSmartags
      ProcedureReturn 0
    Else
      *this\VTABLE = ?VT_Smarttags
      *this\cntRef = 1
      ProcedureReturn *this
    EndIf
   
  EndProcedure
 
  ; -----------------------------------------------------------------------------------
 
  Procedure ClearSmartTags(Tag.s)
    LockSmartTags()
    If FindMapElement(SmartTags(), Tag)
      VariantClear_(SmartTags())
    EndIf
    UnlockSmartTags()
  EndProcedure
 
  ; -----------------------------------------------------------------------------------
 
  DataSection
    VT_Smarttags:
    Data.i @QueryInterface()
    Data.i @AddRef()
    Data.i @Release()
    Data.i @GetTypeInfoCount()
    Data.i @GetTypeInfo()
    Data.i @GetIDsOfNames()
    Data.i @Invoke()
  EndDataSection
 
  ; -----------------------------------------------------------------------------------
 
EndModule

; ***************************************************************************************

_________________
My Projects ThreadToGUI / OOP-BaseClass / OOP-BaseClassDispatch / EventDesigner V3
PB v3.30 / v5.70 - OS Mac Mini OSX 10.xx - VM Window Pro / Linux Ubuntu
Downloads on my Webspace


Last edited by mk-soft on Thu May 30, 2019 10:28 am, edited 10 times in total.

Top
 Profile  
Reply with quote  
 Post subject: Re: Module ActiveScript for VB-Script with PB-Runtime Variab
PostPosted: Sun Sep 16, 2018 1:08 am 
Offline
Addict
Addict
User avatar

Joined: Fri May 12, 2006 6:51 pm
Posts: 2020
Location: Germany
Simple Variant and SafeArray Helper

Update v1.02r2
- Added SafeArrayToArray
- Added SafeArrayToList

Update v2.03
- Optimize code

VariantHelper.pb
Code:
;-TOP

; Comment   : Variant and SafeArray Helper Include
; Author    : mk-soft
; Version   : v2.03
; Create    : 23.09.2018
; Update    : 30.05.2019
; Link      : https://www.purebasic.fr/english/viewtopic.php?f=12&t=71399#p527090

; OS        : Windows

; ***************************************************************************************

;- Structure pData for SafeArray (Like 'C' direct access)

CompilerIf Defined(pData, #PB_Structure) = 0
  Structure pData
    StructureUnion
      llVal.q[0]
      lVal.l[0]
      bVal.b[0]
      iVal.w[0]
      fltVal.f[0]
      dblVal.d[0]
      boolVal.w[0]
      bool.w[0]
      scode.l[0]
      cyVal.l[0]
      date.d[0]
      bstrVal.i[0]
      varVal.VARIANT[0]
      Value.VARIANT[0]
      *punkVal.IUnknown[0]
      *pdispVal.IDispatch[0]
      *parray[0]
      *pbVal.BYTE[0]
      *piVal.WORD[0]
      *plVal.LONG[0]
      *pllVal.QUAD[0]
      *pfltVal.FLOAT[0]
      *pdblVal.DOUBLE[0]
      *pboolVal.LONG[0]
      *pbool.LONG[0]
      *pscode.LONG[0]
      *pcyVal.LONG[0]
      *pdate.DOUBLE[0]
      *pbstrVal.INTEGER[0]
      *ppunkVal.INTEGER[0]
      *ppdispVal.INTEGER[0]
      *pparray.INTEGER[0]
      *pvarVal.VARIANT[0]
      *byref[0]
      cVal.b[0]
      uiVal.w[0]
      ulVal.l[0]
      ullVal.q[0]
      intVal.l[0]
      uintVal.l[0]
      *pdecVal.LONG[0]
      *pcVal.BYTE[0]
      *puiVal.WORD[0]
      *pulVal.LONG[0]
      *pullVal.QUAD[0]
      *pintVal.LONG[0]
      *puintVal.LONG[0]
      decVal.l[0]
      brecord.VARIANT_BRECORD[0]
    EndStructureUnion
  EndStructure
CompilerEndIf

; ++++

;- SafeArray

Procedure GetSafeArrayVartype(*psa.SAFEARRAY)
  Protected vartype
  If SafeArrayGetVartype_(*psa, @vartype) = #S_OK
    ProcedureReturn vartype
  Else
    ProcedureReturn 0
  EndIf
EndProcedure

; ----

Procedure GetSafeArrayDims(*psa.SAFEARRAY)
  ProcedureReturn *psa\cDims
EndProcedure

; ----

Procedure GetSafeArrayElements(*psa.SAFEARRAY, Part) ; Base 1
  If Part < 1 Or Part > *psa\cDims
    ProcedureReturn 0
  Else
    ProcedureReturn *psa\rgsabound[*psa\cDims - Part]\cElements
  EndIf
EndProcedure

; ----

Procedure GetSafeArrayElementPtr(*psa.SAFEARRAY, a, b = 0, c = 0) ; Base 0
  Protected *ptr
 
  With *psa
    Select \cDims
      Case 1
        If a >= \rgsabound[0]\cElements : ProcedureReturn 0 : EndIf
        *ptr = \cbElements * a + \pvData
        ProcedureReturn *ptr
       
      Case 2
        If a >= \rgsabound[1]\cElements : ProcedureReturn 0 : EndIf
        If b >= \rgsabound[0]\cElements : ProcedureReturn 0 : EndIf
        *ptr = \rgsabound[1]\cElements * b
        *ptr + a
        *ptr * \cbElements + \pvData
        ProcedureReturn *ptr
       
      Case 3
        If a >= \rgsabound[2]\cElements : ProcedureReturn 0 : EndIf
        If b >= \rgsabound[1]\cElements : ProcedureReturn 0 : EndIf
        If c >= \rgsabound[0]\cElements : ProcedureReturn 0 : EndIf
        *ptr = \rgsabound[1]\cElements * \rgsabound[2]\cElements * c
        *ptr + \rgsabound[2]\cElements * b
        *ptr + a
        *ptr * \cbElements + \pvData
        ProcedureReturn *ptr
       
      Default
        ProcedureReturn 0
    EndSelect
  EndWith
 
EndProcedure

; ++++

;- Variant

Procedure GetVariantVarType(*Var.Variant)
  If *Var
    ProcedureReturn *Var\vt
  EndIf
EndProcedure

; ----

Procedure.s GetVariantString(*Var.Variant)
  Protected hr, result.s, VarDest.Variant
  If *Var
    If *Var\vt = #VT_BSTR
      ProcedureReturn PeekS(*Var\bstrVal, #PB_Any, #PB_Unicode)
    Else
      hr = VariantChangeType_(VarDest, *Var, 0, #VT_BSTR)
      If hr = #S_OK
        result = PeekS(VarDest\bstrVal, #PB_Any, #PB_Unicode)
        VariantClear_(VarDest)
      EndIf
    EndIf
  EndIf
  ProcedureReturn result
EndProcedure

; ----

Procedure.i GetVariantInteger(*Var.Variant)
  Protected hr, result.i, VarDest.Variant
  If *Var
    CompilerSelect #PB_Compiler_Processor
      CompilerCase #PB_Processor_x86
        If *Var\vt = #VT_I4
          ProcedureReturn *Var\lVal
        Else
          hr = VariantChangeType_(VarDest, *Var, 0, #VT_I4)
          If hr = #S_OK
            result = VarDest\lVal
            VariantClear_(VarDest)
          EndIf
        EndIf
      CompilerCase #PB_Processor_x64
        If *Var\vt = #VT_I8
          ProcedureReturn *Var\llVal
        Else
          hr = VariantChangeType_(VarDest, *Var, 0, #VT_I8)
          If hr = #S_OK
            result = VarDest\llVal
            VariantClear_(VarDest)
          EndIf
        EndIf
    CompilerEndSelect
  EndIf
  ProcedureReturn result
EndProcedure

; ----

Procedure.d GetVariantDouble(*Var.Variant)
  Protected hr, result.d, VarDest.Variant
  If *Var
    If *Var\vt = #VT_R8
      ProcedureReturn *Var\dblVal
    Else
      hr = VariantChangeType_(VarDest, *Var, 0, #VT_R8)
      If hr = #S_OK
        result = VarDest\dblVal
        VariantClear_(VarDest)
      EndIf
    EndIf
  EndIf
  ProcedureReturn result
EndProcedure

; ----

Procedure.i GetVariantDate(*Var.Variant) ; Result PB-Date from Variant Date
  Protected hr, result, VarDest.Variant
  If *Var
    hr = VariantChangeType_(VarDest, *Var, 0, #VT_DATE)
    If hr = #S_OK
      If Int(VarDest\dblVal)
        result = (VarDest\dblVal - 25569.0) * 86400.0
      Else
        result = (VarDest\dblVal) * 86400.0
      EndIf
      VariantClear_(VarDest)
    EndIf
  EndIf
  ProcedureReturn result
EndProcedure

; ----

Procedure.i GetVariantBool(*Var.Variant)
  Protected hr, result, VarDest.Variant
  If *Var
    hr = VariantChangeType_(VarDest, *Var, 0, #VT_BOOL)
    If hr = #S_OK
      If VarDest\bool
        result = #True
      Else
        result = #False
      EndIf
      VariantClear_(VarDest)
    EndIf
  EndIf
  ProcedureReturn result
EndProcedure

; ----

Procedure GetVariantSafeArray(*Var.Variant)
  Protected *psa
  If *Var
    If *Var\vt & #VT_ARRAY
      If *Var\vt & #VT_BYREF
        *psa = *Var\pparray\i
      Else
        *psa = *Var\parray
      EndIf
    EndIf
  EndIf
  ProcedureReturn *psa
EndProcedure

; ----

Procedure SetVariantString(*Var.Variant, String.s)
  If *Var = #PB_Any
    *Var = AllocateStructure(Variant)
  EndIf
  If *Var
    VariantClear_(*Var)
    *Var\vt = #VT_BSTR
    *Var\bstrVal = SysAllocString_(@String)
    ProcedureReturn *Var
  Else
    ProcedureReturn 0
  EndIf
EndProcedure

; ----

Procedure SetVariantInteger(*Var.Variant, Integer)
  If *Var = #PB_Any
    *Var = AllocateStructure(Variant)
  EndIf
  If *Var
    VariantClear_(*Var)
    CompilerSelect #PB_Compiler_Processor
      CompilerCase #PB_Processor_x86
        *Var\vt = #VT_I4
        *Var\lVal = Integer
        ProcedureReturn *Var
      CompilerCase #PB_Processor_x64
        *Var\vt = #VT_I8
        *Var\llVal = Integer
        ProcedureReturn *Var
    CompilerEndSelect
  Else
    ProcedureReturn 0
  EndIf
EndProcedure

; ----

Procedure SetVariantDouble(*Var.Variant, Double.d)
  If *Var = #PB_Any
    *Var = AllocateStructure(Variant)
  EndIf
  If *Var
    VariantClear_(*Var)
    *Var\vt = #VT_R8
    *Var\dblVal = Double
    ProcedureReturn *Var
  Else
    ProcedureReturn 0
  EndIf
EndProcedure

; ----

Procedure SetVariantDate(*Var.Variant, Date)
  If *Var = #PB_Any
    *Var = AllocateStructure(Variant)
  EndIf
  If *Var
    VariantClear_(*Var)
    *Var\vt = #VT_DATE
    *Var\dblVal = Date / 86400.0 + 25569.0
    ProcedureReturn *Var
  Else
    ProcedureReturn 0
  EndIf
EndProcedure

; ----

Procedure SetVariantBool(*Var.Variant, State)
  If *Var = #PB_Any
    *Var = AllocateStructure(Variant)
  EndIf
  If *Var
    VariantClear_(*Var)
    *Var\vt = #VT_BOOL
    If State
      *Var\bool = #VARIANT_TRUE
    Else
      *Var\bool = #VARIANT_FALSE
    EndIf
    ProcedureReturn *Var
  Else
    ProcedureReturn 0
  EndIf
EndProcedure

; ----

Procedure SetVariantSafeArray(*Var.Variant, *SafeArray.SAFEARRAY)
  If *Var = #PB_Any
    *Var = AllocateStructure(Variant)
  EndIf
  If *Var And *SafeArray
    VariantClear_(*Var)
    *Var\vt = #VT_ARRAY | #VT_VARIANT
    *Var\parray = *SafeArray
    ProcedureReturn *Var
  Else
    ProcedureReturn 0
  EndIf
EndProcedure

; ----

Procedure FreeStructureVariant(*Var.Variant)
  If *Var
    VariantClear_(*Var)
    FreeStructure(*Var)
  EndIf
EndProcedure

; ++++

;- Convert Array and List (Strings)

; Covert an array of type string to a simple safearray of type variant

Procedure ArrayToSafeArray(Array Strings.s(1), LBound = 0)
  Protected rgsabound.SAFEARRAYBOUND, *psa.SAFEARRAY, Index, UBound
 
  UBound = ArraySize(Strings())
  rgsabound\lLbound = LBound
  rgsabound\cElements = UBound + 1
 
  *psa = SafeArrayCreate_(#VT_VARIANT, 1, rgsabound)
  If *psa
    For Index = 0 To UBound
      *psa\pvData\Value[Index]\vt = #VT_BSTR
      *psa\pvData\Value[Index]\bstrVal = SysAllocString_(Strings(Index))
    Next
    ProcedureReturn *psa
  Else
    ProcedureReturn 0
  EndIf
EndProcedure

; ----

; Convert a simple safearray of type variant to an array of type string

Procedure SafeArrayToArray(*Source.SAFEARRAY, Array Dest.s(1))
  Protected cnt, index, vartype
 
  cnt = -1
  If *Source And *Source\cDims = 1
    If SafeArrayGetVartype_(*Source, @vartype) = #S_OK
      If vartype = #VT_VARIANT
        cnt = *Source\rgsabound[0]\cElements - 1
        Dim Dest(cnt)
        For index = 0 To cnt
          Dest(index) = GetVariantString(*Source\pvData\Value[index])
        Next
      EndIf
    EndIf
  EndIf
  ProcedureReturn cnt
EndProcedure

; ----

; Convert a list of type string to a simple safearry of type variant

Procedure ListToSafeArray(List Strings.s(), LBound = 0)
  Protected rgsabound.SAFEARRAYBOUND, *psa.SAFEARRAY, Index, Size
 
  Size = ListSize(Strings())
  If Size
    rgsabound\lLbound = LBound
    rgsabound\cElements = Size
   
    *psa = SafeArrayCreate_(#VT_VARIANT, 1, rgsabound)
    If *psa
      index = 0
      ForEach Strings()
        *psa\pvData\Value[Index]\vt = #VT_BSTR
        Debug Strings()
        *psa\pvData\Value[Index]\bstrVal = SysAllocString_(Strings())
        index + 1
      Next
      ProcedureReturn *psa
    Else
      ProcedureReturn 0
    EndIf
  Else
    ProcedureReturn 0
  EndIf
 
EndProcedure

; ----

; Convert a simple safearray of type variant to a list of type string

Procedure SafeArrayToList(*Source.SAFEARRAY, List Dest.s())
  Protected cnt, index, vartype
 
  ClearList(Dest())
  If *Source And *Source\cDims = 1
    If SafeArrayGetVartype_(*Source, @vartype) = #S_OK
      If vartype = #VT_VARIANT
        cnt = *Source\rgsabound[0]\cElements - 1
        For index = 0 To cnt
          AddElement(Dest())
          Dest() = GetVariantString(*Source\pvData\Value[index])
        Next
      EndIf
    EndIf
  EndIf
  ProcedureReturn cnt
EndProcedure

; ----

; ***************************************************************************************

_________________
My Projects ThreadToGUI / OOP-BaseClass / OOP-BaseClassDispatch / EventDesigner V3
PB v3.30 / v5.70 - OS Mac Mini OSX 10.xx - VM Window Pro / Linux Ubuntu
Downloads on my Webspace


Last edited by mk-soft on Thu May 30, 2019 10:30 am, edited 6 times in total.

Top
 Profile  
Reply with quote  
 Post subject: Re: Module ActiveScript for VB-Script with PB-Runtime Variab
PostPosted: Mon Sep 17, 2018 8:10 pm 
Offline
Addict
Addict
User avatar

Joined: Fri May 12, 2006 6:51 pm
Posts: 2020
Location: Germany
Update v1.04 Beta
- Bugfix QueryInterface IActiveScriptSiteWindow
- Fixed RefCounter

More debugging on level 2 :wink:

_________________
My Projects ThreadToGUI / OOP-BaseClass / OOP-BaseClassDispatch / EventDesigner V3
PB v3.30 / v5.70 - OS Mac Mini OSX 10.xx - VM Window Pro / Linux Ubuntu
Downloads on my Webspace


Top
 Profile  
Reply with quote  
 Post subject: Re: Module ActiveScript for VB-Script with PB-Runtime Variab
PostPosted: Mon Sep 17, 2018 8:37 pm 
Offline
Addict
Addict
User avatar

Joined: Sun Nov 05, 2006 11:42 pm
Posts: 4520
Location: Lyon - France
Always impressive by your hard work :shock:
But not always at the good level for understand it :oops:
Apparently that works here, better you see yourself :wink: :lol:

Quote:
ActiveScriptSite - AddRef() : Refcount 1 > 2
ActiveScriptSite - QueryInterface() : IActiveScriptSiteInterruptPoll -> Ok
SiteInterruptPoll - AddRef() : Refcount = 1 > 2
ActiveScriptSite - AddRef() : Refcount 2 > 3
ActiveScriptSite - QueryInterface() : IActiveScriptSiteDebug -> No Interface
ActiveScriptSite - OnStateChange() : State = 5
ActiveScriptSite - OnStateChange() : State = 1
ActiveScriptSite - OnStateChange() : State = 2
ActiveScriptSite - AddRef() : Refcount 3 > 4
ActiveScriptSite - OnEnterScript()
ActiveScriptSite - GetItemInfo() : VbsName = SmartTags
SmartTags - QueryInterface()
SmartTags - Release() : Refcount = 2 > 1
SmartTags - AddRef() : Refcount = 1 > 2
SmartTags - Release() : Refcount = 2 > 1
SmartTags - AddRef() : Refcount = 1 > 2
SmartTags - QueryInterface()
SmartTags - Invoke() PropertyPut : DispId = 0
SmartTags - Release() : Refcount = 2 > 1
SmartTags - AddRef() : Refcount = 1 > 2
SmartTags - QueryInterface()
SmartTags - Invoke() PropertyPut : DispId = 0
SmartTags - Release() : Refcount = 2 > 1
SmartTags - AddRef() : Refcount = 1 > 2
SmartTags - QueryInterface()
SmartTags - Invoke() PropertyPut : DispId = 0
SmartTags - Release() : Refcount = 2 > 1
SmartTags - AddRef() : Refcount = 1 > 2
SmartTags - QueryInterface()
SmartTags - Invoke() PropertyGet : DispId = 0
SmartTags - Release() : Refcount = 2 > 1
SmartTags - AddRef() : Refcount = 1 > 2
SmartTags - QueryInterface()
SmartTags - Invoke() PropertyGet : DispId = 0
SmartTags - Release() : Refcount = 2 > 1
ActiveScriptSite - QueryInterface() : IActiveScriptSiteUIControl -> No Interface
ActiveScriptSite - QueryInterface() : IActiveScriptSiteWindow -> Ok
ActiveScriptSiteWindow - AddRef() : Refcount = 1 > 2
ActiveScriptSiteWindow - GetWindow()
ActiveScriptSiteWindow - EnableModless()

Quote:
1. PB-Runtime Variables
Title = I like Purebasic
Value = 199.8
Index = 100
*** NewActiveScript() ***
ActiveScriptSite - AddRef() : Refcount 1 > 2
ActiveScriptSite - QueryInterface() : IActiveScriptSiteInterruptPoll -> Ok
SiteInterruptPoll - AddRef() : Refcount = 1 > 2
ActiveScriptSite - AddRef() : Refcount 2 > 3
ActiveScriptSite - QueryInterface() : IActiveScriptSiteDebug -> No Interface
ActiveScriptSite - OnStateChange() : State = 5
ActiveScriptSite - OnStateChange() : State = 1
ActiveScriptSite - OnStateChange() : State = 2
*** ParseScriptText(vbs) ***
ActiveScriptSite - AddRef() : Refcount 3 > 4
ActiveScriptSite - OnEnterScript()
ActiveScriptSite - GetItemInfo() : VbsName = Runtime
Runtime - QueryInterface() : IDispatch -> Ok
Runtime - Release() : Refcount = 2 > 1
Runtime - AddRef() : Refcount = 1 > 2
Runtime - Release() : Refcount = 2 > 1
Runtime - QueryInterface() : IDispatchEx -> No Interface
Runtime - GetIDsOfNames() : Name = string DispId = 3
Runtime - AddRef() : Refcount = 1 > 2
Runtime - QueryInterface() : IDispatchEx -> No Interface
Runtime - Invoke() PropertyGet : DispId = 3
Runtime - Release() : Refcount = 2 > 1
Runtime - QueryInterface() : IDispatchEx -> No Interface
Runtime - GetIDsOfNames() : Name = double DispId = 2
Runtime - AddRef() : Refcount = 1 > 2
Runtime - QueryInterface() : IDispatchEx -> No Interface
Runtime - Invoke() PropertyGet : DispId = 2
Runtime - Release() : Refcount = 2 > 1
Runtime - QueryInterface() : IDispatchEx -> No Interface
Runtime - GetIDsOfNames() : Name = integer DispId = 1
Runtime - AddRef() : Refcount = 1 > 2
Runtime - QueryInterface() : IDispatchEx -> No Interface
Runtime - Invoke() PropertyGet : DispId = 1
Runtime - Release() : Refcount = 2 > 1
Runtime - QueryInterface() : IDispatchEx -> No Interface
Runtime - GetIDsOfNames() : Name = integer DispId = 1
Runtime - AddRef() : Refcount = 1 > 2
Runtime - QueryInterface() : IDispatchEx -> No Interface
Runtime - Invoke() PropertyPut : DispId = 1
Runtime - Release() : Refcount = 2 > 1
ActiveScriptSite - QueryInterface() : IActiveScriptSiteUIControl -> No Interface
ActiveScriptSite - QueryInterface() : IActiveScriptSiteWindow -> Ok
ActiveScriptSiteWindow - AddRef() : Refcount = 1 > 2
ActiveScriptSiteWindow - GetWindow()
ActiveScriptSiteWindow - EnableModless()
ActiveScriptSiteWindow - EnableModless()
ActiveScriptSiteWindow - Release() : Refcount = 2 > 1
Runtime - QueryInterface() : IDispatchEx -> No Interface
Runtime - GetIDsOfNames() : Name = string DispId = 3
Runtime - AddRef() : Refcount = 1 > 2
Runtime - QueryInterface() : IDispatchEx -> No Interface
Runtime - Invoke() PropertyPut : DispId = 3
Runtime - Release() : Refcount = 2 > 1
Runtime - QueryInterface() : IDispatchEx -> No Interface
Runtime - GetIDsOfNames() : Name = double DispId = 2
Runtime - AddRef() : Refcount = 1 > 2
Runtime - QueryInterface() : IDispatchEx -> No Interface
Runtime - Invoke() PropertyPut : DispId = 2
Runtime - Release() : Refcount = 2 > 1
ActiveScriptSite - OnLeaveScript()
ActiveScriptSite - Release() : Refcount = 4 > 3
Code Ready.
*** FreeActiveScript() ***
ActiveScriptSite - Release() : Refcount = 3 > 2
ActiveScriptSite - Release() : Refcount = 2 > 1
ActiveScriptSite - Release() : Refcount = 1 > 0
SiteInterruptPoll - Release() : Refcount = 2 > 1
SiteInterruptPoll - Release() : Refcount = 1 > 0
ActiveScriptSiteWindow - Release() : Refcount = 1 > 0
Runtime - Release() : Refcount = 1 > 0
2. PB-Runtime Variables
Title = ActiveScript Purebasic Runtime
Value = 0.1234567
Index = 200

Thanks for your sharing 8)

_________________
ImageThe happiness is a road...
Not a destination


Top
 Profile  
Reply with quote  
 Post subject: Re: Module ActiveScript for VB-Script with PB-Runtime Variab
PostPosted: Tue Sep 18, 2018 6:23 pm 
Offline
Addict
Addict
User avatar

Joined: Fri May 12, 2006 6:51 pm
Posts: 2020
Location: Germany
New Example with SafeArray to VB-Script :wink:

Update v2.01
- Used new VariantHelper.pb

Code:
;-TOP

; Comment   : Modul ActiveScript Example 1
; Version   : v2.01

; Link to ActiveScript  : https://www.purebasic.fr/english/viewtopic.php?f=12&t=71399
; Link to SmartTags     : https://www.purebasic.fr/english/viewtopic.php?f=12&t=71399#p527089
; Link to VariantHelper : https://www.purebasic.fr/english/viewtopic.php?f=12&t=71399#p527090

; ***************************************************************************************

XIncludeFile "Modul_ActiveScript.pb"
XIncludeFile "Modul_SmartTags.pb"
XIncludeFile "VariantHelper.pb"

UseModule ActiveScript
UseModule ActiveSmartTags

; -------------------------------------------------------------------------------------

Global vbs.s, name.s, *psa_files, *psa_text
Global Dim files.s(3)
Global NewList Text.s()

; Variable als Rumtime definieren zum Zugriff aus VB-Script
Runtime name

; Daten anlegen
name = "test.xls"
files(0) = "Image-1.jpg"
files(1) = "Image-2.jpg"
files(2) = "Image-3.jpg"
files(3) = "Image-4.jpg"

AddElement(Text()) : Text() = "Hello World"
AddElement(Text()) : Text() = "I like Purebasic"

; Das Array in ein SafeArray wandeln
*psa_files = ArrayToSafeArray(files())
; Das SafeArray zum SmartTag zuweisen
SetVariantSafeArray(SmartTags("files"), *psa_files)

; Die Liste in ein SafeArray wandeln
*psa_text = ListToSafeArray(Text())
; Das SafeArray zum SmartTag zuweisen
SetVariantSafeArray(SmartTags("texte"), *psa_text)

; VB-Script schreiben
vbs + "Dim name, file, files, texte, result" + #LF$
vbs + "" + #LF$
vbs + "name = Runtime.String('name')" + #LF$
vbs + "result = 'Name: ' & name & vbNewLine" + #LF$
vbs + "" + #LF$
vbs + "files = SmartTags('files')" + #LF$
vbs + "texte = SmartTags('texte')" + #LF$
vbs + "" + #LF$
vbs + "result = result & vbNewline & 'Array:' & vbNewline" + #LF$
vbs + "If IsArray(files) Then" + #LF$
vbs + "  For Each file In Files" + #LF$
vbs + "    result = result & file & vbNewLine" + #LF$
vbs + "   Next" + #LF$
vbs + "Else" + #LF$
vbs + "  result = 'No Array'" + #LF$
vbs + "End If" + #LF$
vbs + "" + #LF$
vbs + "result = result & vbNewline & 'List:' & vbNewline" + #LF$
vbs + "If IsArray(texte) Then" + #LF$
vbs + "  result = result & texte(0) & vbNewLine" + #LF$
vbs + "  result = result & texte(1) & vbNewLine" + #LF$
vbs + "Else" + #LF$
vbs + "  result = 'No Array'" + #LF$
vbs + "End If" + #LF$
vbs + "" + #LF$
vbs + "MsgBox result" + #LF$
vbs + "" + #LF$

vbs = ReplaceString(vbs, "'", #DQUOTE$)

; VB-Script ausführen
Debug "**********************************"
*Control = NewActiveScript()
If *Control
  ; AddOn SmartTags hinzufügen
  AddNamedObject(*Control, "SmartTags", NewSmartTags())
  Debug "**********************************"
  Debug vbs
  Debug "**********************************"
  ParseScriptText(*Control, vbs)
  Debug "**********************************"
  FreeActiveScript(*Control)
EndIf

; SafeArray Speicher freigeben
ClearSmartTags("files")
ClearSmartTags("texte")

_________________
My Projects ThreadToGUI / OOP-BaseClass / OOP-BaseClassDispatch / EventDesigner V3
PB v3.30 / v5.70 - OS Mac Mini OSX 10.xx - VM Window Pro / Linux Ubuntu
Downloads on my Webspace


Last edited by mk-soft on Sun May 26, 2019 1:23 pm, edited 4 times in total.

Top
 Profile  
Reply with quote  
 Post subject: Re: Module ActiveScript for VB-Script with PB-Runtime Variab
PostPosted: Wed Sep 19, 2018 4:25 pm 
Offline
Addict
Addict
User avatar

Joined: Fri May 12, 2006 6:51 pm
Posts: 2020
Location: Germany
Example 2 - SafeArray Direct Access

Update v2.01
Code:
;-TOP

; Comment   : Modul ActiveScript Example 2 - SafeArray
; Version   : v2.01

; Link to ActiveScript  : https://www.purebasic.fr/english/viewtopic.php?f=12&t=71399
; Link to SmartTags     : https://www.purebasic.fr/english/viewtopic.php?f=12&t=71399#p527089
; Link to VariantHelper : https://www.purebasic.fr/english/viewtopic.php?f=12&t=71399#p527090

; ***************************************************************************************

XIncludeFile "Modul_ActiveScript.pb"
XIncludeFile "Modul_SmartTags.pb"
XIncludeFile "VariantHelper.pb"

UseModule ActiveScript
UseModule ActiveSmartTags

; -------------------------------------------------------------------------------------

;EnableExplicit

Global vbs.s, *psa.SAFEARRAY, *var.variant
Global x, y, z

vbs = "" + #LF$
vbs + "dim daten(3,1,2)" + #LF$
vbs + "" + #LF$
vbs + "daten(0,0,1) = 1" + #LF$
vbs + "daten(2,1,2) = 2" + #LF$
vbs + "daten(1,0,0) = 3" + #LF$
vbs + "daten(1,0,1) = '4 : Its work ;)'" + #LF$
vbs + "" + #LF$
vbs + "SmartTags('daten') = daten" + #LF$
vbs + "" + #LF$

vbs = ReplaceString(vbs, "'", #DQUOTE$)

*Control = NewActiveScript()
If *Control
  AddNamedObject(*Control, "SmartTags", NewSmartTags())
  Debug "************************************************************"
  Debug vbs
  Debug "************************************************************"
  ParseScriptText(*Control, vbs)
  FreeActiveScript(*Control)

  *psa = GetVariantSafeArray(SmartTags("daten"))
  If *psa
   
    Debug "************************************************************"
    Debug "Dims = " + GetSafeArrayDims(*psa)
    Debug "************************************************************"
   
    For x = 0 To GetSafeArrayElements(*psa, 1) - 1
      For y = 0 To GetSafeArrayElements(*psa, 2) - 1
        For z = 0 To GetSafeArrayElements(*psa, 3) - 1
          Debug "Daten(" + x + "," + y + "," + z + ") = " + GetVariantString(GetSafeArrayElementPtr(*psa, x, y, z))
        Next
      Next
    Next
    Debug "************************************************************"
  EndIf 
EndIf

_________________
My Projects ThreadToGUI / OOP-BaseClass / OOP-BaseClassDispatch / EventDesigner V3
PB v3.30 / v5.70 - OS Mac Mini OSX 10.xx - VM Window Pro / Linux Ubuntu
Downloads on my Webspace


Last edited by mk-soft on Sun May 26, 2019 1:24 pm, edited 4 times in total.

Top
 Profile  
Reply with quote  
 Post subject: Re: Module ActiveScript for VB-Script with PB-Runtime Variab
PostPosted: Thu Sep 20, 2018 1:40 pm 
Offline
Addict
Addict
User avatar

Joined: Sun Nov 05, 2006 11:42 pm
Posts: 4520
Location: Lyon - France
Thanks for sharing 8)

_________________
ImageThe happiness is a road...
Not a destination


Top
 Profile  
Reply with quote  
 Post subject: Re: Module ActiveScript for VB-Script with PB-Runtime Variab
PostPosted: Sun Sep 23, 2018 5:30 pm 
Offline
Addict
Addict
User avatar

Joined: Fri May 12, 2006 6:51 pm
Posts: 2020
Location: Germany
Some Update

ActiveScript Update v1.05
- Optimize debug output and debug level

SmartTags Update v1.04
- Optimize debug output and debug level

Added a new Variant and SafeArray Helper : viewtopic.php?f=12&t=71399#p527090

Update v2.01
Code:
;-TOP

; Comment   : Modul ActiveScript Example 3
; Version   : v2.01

; Link to ActiveScript  : https://www.purebasic.fr/english/viewtopic.php?f=12&t=71399
; Link to SmartTags     : https://www.purebasic.fr/english/viewtopic.php?f=12&t=71399#p527089
; Link to VariantHelper : https://www.purebasic.fr/english/viewtopic.php?f=12&t=71399#p527090

; ***************************************************************************************

XIncludeFile "Modul_ActiveScript.pb"
XIncludeFile "Modul_SmartTags.pb"
XIncludeFile "VariantHelper.pb"

UseModule ActiveScript
UseModule ActiveSmartTags

; -------------------------------------------------------------------------------------

; EnableExplicit

Global vbs.s, time , value.d

vbs = "msgbox smarttags('datum')" + #LF$
vbs + "smarttags('datum') = now()" + #LF$
vbs + "smarttags('time') = time()" + #LF$
vbs + "smarttags('value') = (smarttags('value') + 1.0) * 2.0" + #LF$

vbs = ReplaceString(vbs, "'", #DQUOTE$)

SetVariantDate(SmartTags("datum"), Date())
SetVariantDouble(SmartTags("value"), 100.0)

Debug "************************************************************"
*Control = NewActiveScript()
If *Control
  AddNamedObject(*Control, "SmartTags", NewSmartTags())
  Debug "************************************************************"
  Debug vbs
  Debug "************************************************************"
  ParseScriptText(*Control, vbs)
  FreeActiveScript(*Control)
  Debug "************************************************************"
  Debug "Date = " + GetVariantString(SmartTags("datum"))
  time = GetVariantDate(SmartTags("time"))
  Debug "Time = " + FormatDate("%hh:%ii:%ss", time)
  Debug "Value = " + GetVariantDouble(SmartTags("value"))
EndIf

_________________
My Projects ThreadToGUI / OOP-BaseClass / OOP-BaseClassDispatch / EventDesigner V3
PB v3.30 / v5.70 - OS Mac Mini OSX 10.xx - VM Window Pro / Linux Ubuntu
Downloads on my Webspace


Last edited by mk-soft on Sun May 26, 2019 1:26 pm, edited 2 times in total.

Top
 Profile  
Reply with quote  
 Post subject: Re: Module ActiveScript for VB-Script with PB-Runtime Variab
PostPosted: Sat Oct 20, 2018 4:19 pm 
Offline
Addict
Addict
User avatar

Joined: Fri May 12, 2006 6:51 pm
Posts: 2020
Location: Germany
Update v2.01
- Added Runtime.Sleep [milliseconds]

WScript.Shell not longer support sleep...

Example 4 - Load Webpage over Internet-Explorer
Code:
;-TOP

; Comment   : Modul ActiveScript Example 4
; Version   : v2.01

; Link to ActiveScript  : https://www.purebasic.fr/english/viewtopic.php?f=12&t=71399
; Link to SmartTags     : https://www.purebasic.fr/english/viewtopic.php?f=12&t=71399#p527089
; Link to VariantHelper : https://www.purebasic.fr/english/viewtopic.php?f=12&t=71399#p527090

; ***************************************************************************************

XIncludeFile "Modul_ActiveScript.pb"
;XIncludeFile "Modul_SmartTags.pb"
;XIncludeFile "VariantHelper.pb"

UseModule ActiveScript
;UseModule ActiveSmartTags

; -------------------------------------------------------------------------------------

Global vbs.s, result.s

; Variable als Rumtime definieren zum Zugriff aus VB-Script
Runtime result

; Daten anlegen

; VB-Script schreiben
vbs = ~""
vbs + ~"Dim IE, Result" + #LF$
vbs + ~"Set IE = CreateObject(\"InternetExplorer.Application\")" + #LF$
vbs + ~"IE.Visible = False ' True or hide" + #LF$
vbs + ~"IE.Navigate \"www.purebasic.com\"" + #LF$
vbs + ~"Do While IE.busy = True" + #LF$
vbs + ~"  Runtime.Sleep 500" + #LF$
vbs + ~"Loop" + #LF$
vbs + ~"Result = IE.document.documentElement.outerHTML" + #LF$
vbs + ~"Runtime.String(\"result\") = Result" + #LF$
vbs + ~"IE.Quit" + #LF$

*Control = NewActiveScript()
If *Control
  Debug "************************************************************"
  Debug vbs
  Debug "************************************************************"
  ParseScriptText(*Control, vbs);, #SCRIPTTEXT_ISVISIBLE)
  FreeActiveScript(*Control)
  Debug "************************************************************"
  Debug result
EndIf

_________________
My Projects ThreadToGUI / OOP-BaseClass / OOP-BaseClassDispatch / EventDesigner V3
PB v3.30 / v5.70 - OS Mac Mini OSX 10.xx - VM Window Pro / Linux Ubuntu
Downloads on my Webspace


Last edited by mk-soft on Sun May 26, 2019 1:28 pm, edited 1 time in total.

Top
 Profile  
Reply with quote  
 Post subject: Re: Module ActiveScript for VB-Script with PB-Runtime Variab
PostPosted: Sun Oct 21, 2018 4:13 pm 
Offline
Enthusiast
Enthusiast
User avatar

Joined: Thu Mar 25, 2004 2:15 pm
Posts: 702
Location: Spain
mk-soft wrote:
Update v1.06
- Added Runtime.Sleep [milliseconds]

WScript.Shell not longer support sleep...

Example 4 - Load Webpage over Internet-Explorer
Code:
;-TOP

; Comment   : Modul ActiveScript Example 4

; Link to ActiveScript  : https://www.purebasic.fr/english/viewtopic.php?f=12&t=71399
; Link to SmartTags     : https://www.purebasic.fr/english/viewtopic.php?f=12&t=71399#p527089
; Link to VariantHelper : https://www.purebasic.fr/english/viewtopic.php?f=12&t=71399#p527090

; ***************************************************************************************

XIncludeFile "Modul_ActiveScript.pb"
;XIncludeFile "Modul_SmartTags.pb"
;XIncludeFile "VariantHelper.pb"

UseModule ActiveScript
;UseModule ActiveSmartTags

; -------------------------------------------------------------------------------------

Global vbs.s, result.s

; Variable als Rumtime definieren zum Zugriff aus VB-Script
Runtime result

; Daten anlegen

; VB-Script schreiben
vbs = ~""
vbs + ~"Dim IE" + #LF$
vbs + ~"Set IE = CreateObject(\"InternetExplorer.Application\")" + #LF$
vbs + ~"IE.Navigate \"www.purebasic.com\"" + #LF$
vbs + ~"IE.Visible = True 'or hide" + #LF$
vbs + ~"Do While IE.busy = True" + #LF$
vbs + ~"  Runtime.Sleep 500" + #LF$
vbs + ~"Loop" + #LF$
vbs + ~"Runtime.String(\"result\") = IE.document.documentElement.outerHTML" + #LF$
vbs + ~"IE.Quit" + #LF$


If NewActiveScript()
  Debug "************************************************************"
  Debug vbs
  Debug "************************************************************"
  ParseScriptText(vbs)
  FreeActiveScript()
  Debug "************************************************************"
  Debug result
EndIf


Hi! I got this error with the last sample (Windows 10x64, PB 5.70x64)

https://prnt.sc/l8mwoe

_________________
PB 5.7x, PureVision User.


Top
 Profile  
Reply with quote  
 Post subject: Re: Module ActiveScript for VB-Script with PB-Runtime Variab
PostPosted: Sun Oct 21, 2018 5:39 pm 
Offline
Addict
Addict
User avatar

Joined: Fri May 12, 2006 6:51 pm
Posts: 2020
Location: Germany
Check your security settings from Internet explorer...

With me it runs with the not changed standard settings under Windows 10.

_________________
My Projects ThreadToGUI / OOP-BaseClass / OOP-BaseClassDispatch / EventDesigner V3
PB v3.30 / v5.70 - OS Mac Mini OSX 10.xx - VM Window Pro / Linux Ubuntu
Downloads on my Webspace


Top
 Profile  
Reply with quote  
 Post subject: Re: Module ActiveScript for VB-Script with PB-Runtime Variab
PostPosted: Sun Oct 21, 2018 6:47 pm 
Offline
Addict
Addict
User avatar

Joined: Tue Mar 02, 2004 1:20 pm
Posts: 1032
Location: Amphibios 9
no problems here either (Windows 10 pro)

_________________
Can't decide if i need a hug, an XXL coffee, 6 shots of vodka or 2 weeks of sleep.


Top
 Profile  
Reply with quote  
 Post subject: Re: Module ActiveScript for VB-Script with PB-Runtime Variab
PostPosted: Sun Oct 21, 2018 7:10 pm 
Offline
Enthusiast
Enthusiast
User avatar

Joined: Thu Mar 25, 2004 2:15 pm
Posts: 702
Location: Spain
mk-soft wrote:
Check your security settings from Internet explorer...

With me it runs with the not changed standard settings under Windows 10.

Thank you for reply!

I just checked the Internet Explorer options and I have it all by default.
So I've given it to reset IE configuration (4th image), but the error remains.

I also disable antivirus (Eset Nod), Defender and firewall with no changes.

My IE config: http://prntscr.com/l8ou9z

_________________
PB 5.7x, PureVision User.


Top
 Profile  
Reply with quote  
 Post subject: Re: Module ActiveScript for VB-Script with PB-Runtime Variab
PostPosted: Sun Oct 21, 2018 8:31 pm 
Offline
Enthusiast
Enthusiast
User avatar

Joined: Thu Mar 25, 2004 2:15 pm
Posts: 702
Location: Spain
:shock: Okay, the problem is on my team.
I recorded the script in a.vbs file and executed it on the command line:
Code:
cscript.exe sample.vbs or
wscript.exe sample.vbs or
%windir%\SysWOW64\cscript.exe sample.vbs or
%windir%\SysWOW64\wscript.exe sample.vbs

And in both cases it fails; it's my turn to check my computer!

I'm sorry I wasted your time!

_________________
PB 5.7x, PureVision User.


Top
 Profile  
Reply with quote  
Display posts from previous:  Sort by  
Post new topic Reply to topic  [ 30 posts ]  Go to page 1, 2  Next

All times are UTC + 1 hour


Who is online

Users browsing this forum: No registered users and 11 guests


You cannot post new topics in this forum
You cannot reply to topics in this forum
You cannot edit your posts in this forum
You cannot delete your posts in this forum

Search for:
Jump to:  

 


Powered by phpBB © 2008 phpBB Group
subSilver+ theme by Canver Software, sponsor Sanal Modifiye