Module ActiveScript for VB-Script with PB-Runtime Variables

Share your advanced PureBasic knowledge/code with the community.
User avatar
mk-soft
Always Here
Always Here
Posts: 5335
Joined: Fri May 12, 2006 6:51 pm
Location: Germany

Module ActiveScript for VB-Script with PB-Runtime Variables

Post by mk-soft »

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

Update v2.07
- Bugfix ActiveScriptSite cntRef
- Bugfix ActiveScriptSiteWindow -> QuerInterface
- Bugfix ActiveScriptSiteInteruptPull -> QuerInterface
- Cleanup Code

Update v2.08
- Bugfix ActiveScriptSite -> OnScriptError

Update v2.09
- Change Debug Levels
- Added DebugLevelRuntimeTrace (1)

Modul_ActiveScript.pb

Code: Select all

;-TOP

; Comment   : Modul ActiveScript
; Author    : mk-soft
; Version   : v2.09.1
; Create    : 15.09.2018
; Update    : 24.07.2020

; 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

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

; 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 = 1
  
  ; Define Debuglevel
  #DebugLevelRuntimeTrace   = 1
  #DebugLevelRuntimeDebug   = 4
  #DebugLevelActiveScript   = 5
  #DebugLevelActiveScriptEx = 6
  
  #UseActiveScriptInterruptPull = #False
  #UseActiveScriptDebugView     = #False
  
  ; -----------------------------------------------------------------------------------
  
  ;-- 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", #DebugLevelRuntimeDebug
      *Object\i = *This
      *This\cntRef + 1
      ProcedureReturn #S_OK
    ElseIf CompareMemory(*iid, ?IID_IDispatch, 16)
      Debug "Runtime - QueryInterface() : IDispatch -> Ok", #DebugLevelRuntimeDebug
      *Object\i = *This
      *This\cntRef + 1
      ProcedureReturn #S_OK
    ElseIf CompareMemory(*iid, ?IID_IDispatchEx, 16)
      ; Debug "Runtime - QueryInterface() : IDispatchEx -> No Interface", #DebugLevelRuntimeDebug
      *Object\i = 0
      ProcedureReturn #E_NOINTERFACE
    Else
      Debug "Runtime - QueryInterface() : No Interface", #DebugLevelRuntimeDebug
      *Object\i = 0
      ProcedureReturn #E_NOINTERFACE
    EndIf
    
  EndProcedure
  
  ; -----------------------------------------------------------------------------------
  
  Procedure AddRef(*This.objRuntime)
    
    Debug "Runtime - AddRef() :  Refcount = " + Str(*This\cntRef) + " > " + Str(*This\cntRef + 1), #DebugLevelRuntimeDebug
    *This\cntRef + 1
    ProcedureReturn *This\cntRef
    
  EndProcedure
  
  ; -----------------------------------------------------------------------------------
  
  Procedure Release(*This.objRuntime)
    
    *This\cntRef - 1
    If *This\cntRef < 1
      Debug "Runtime - Release() : Destroy Object", #DebugLevelRuntimeDebug
      FreeStructure(*This)
      ProcedureReturn 0
    Else
      Debug "Runtime - Release() : Refcount = " + Str(*This\cntRef + 1) + " > " + Str(*This\cntRef), #DebugLevelRuntimeDebug
      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", #DebugLevelRuntimeDebug
        ProcedureReturn #DISP_E_MEMBERNOTFOUND
        
    EndSelect
    
    Debug "Runtime - GetIDsOfNames() : Name = " + Name + " -> DispId = " + *DispId\l, #DebugLevelRuntimeDebug
    
    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, #DebugLevelRuntimeDebug
          If IsRuntime(name) And Right(name,2) = "()"
            *Call = GetRuntimeInteger(name)
            If *Call
              ProcedureReturn *Call(cArgs, *vArgs, *vResult)
            EndIf
          Else
            ProcedureReturn #DISP_E_BADVARTYPE
          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, #DebugLevelRuntimeDebug
          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, #DebugLevelRuntimeDebug
          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, #DebugLevelRuntimeDebug
          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, #DebugLevelRuntimeDebug
          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, #DebugLevelRuntimeDebug
          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, #DebugLevelRuntimeDebug
          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, #DebugLevelRuntimeDebug
          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, #DebugLevelRuntimeDebug
        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.Trace: " + name, #DebugLevelRuntimeTrace
        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", #DebugLevelRuntimeDebug
      ProcedureReturn 0
    Else
      Debug "New ActiveRuntime - Allocate Object", #DebugLevelActiveScriptEx
      *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 objActiveScriptSiteInterruptPoll
    *VTable
    cntRef.i
    *IID.IID
    *Me.cSH
    time.i
  EndStructure
  
  ; -----------------------------------------------------------------------------------
  
  Procedure QueryInterface(*This.objActiveScriptSiteInterruptPoll, *iid.IID, *Object.Integer)
    
    ; Standardzuweisungen auf eigenes Objekt
    If CompareMemory(*iid, ?IID_IUnknown, 16)
      Debug "ActiveScriptSiteInterruptPoll - QueryInterface() : IUnknown -> Ok", #DebugLevelActiveScript
      *Object\i = *This
      *This\cntRef + 1
      ProcedureReturn #S_OK
    Else
      Debug "ActiveScriptSiteInterruptPoll - QueryInterface() : No Interface", #DebugLevelActiveScript
      *Object\i = 0
      ProcedureReturn #E_NOINTERFACE
    EndIf
    
  EndProcedure
  
  ; -----------------------------------------------------------------------------------
  
  Procedure AddRef(*This.objActiveScriptSiteInterruptPoll)
    
    Debug "ActiveScriptSiteInterruptPoll - AddRef() :  Refcount = " + Str(*This\cntRef) + " > " + Str(*This\cntRef + 1), #DebugLevelActiveScript
    *This\cntRef + 1
    ProcedureReturn *This\cntRef
    
  EndProcedure
  
  ; -----------------------------------------------------------------------------------
  
  Procedure Release(*This.objActiveScriptSiteInterruptPoll)
    
    *This\cntRef - 1
    If *This\cntRef < 1
      Debug "ActiveScriptSiteInterruptPoll - Release() : Destroy Object", #DebugLevelActiveScript
      FreeStructure(*This)
      ProcedureReturn 0
    Else
      Debug "ActiveScriptSiteInterruptPoll - Release() : Refcount = " + Str(*This\cntRef + 1) + " > " + Str(*This\cntRef), #DebugLevelActiveScript
      ProcedureReturn *This\cntRef
    EndIf
  EndProcedure
  
  ; -----------------------------------------------------------------------------------
  
  Procedure QueryContinue(*This.objActiveScriptSiteInterruptPoll)
    
    Debug "ActiveScriptSiteInterruptPoll - 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.objActiveScriptSiteInterruptPoll
    
    *this = AllocateStructure(objActiveScriptSiteInterruptPoll)
    If *this = 0
      Debug "New ActiveScriptSiteInterruptPoll - Out Of Memory", #DebugLevelActiveScript
      ProcedureReturn 0
    Else
      Debug "New ActiveScriptSiteInterruptPoll - Allocate Object", #DebugLevelActiveScriptEx
      *this\VTABLE = ?VT_ActiveScriptSiteInterruptPoll
      *this\IID    = ?IID_IActiveScriptSiteInterruptPoll
      *this\cntRef = 1
      *this\Me     = 0
      ProcedureReturn *this
    EndIf
    
  EndProcedure
  
  ; -----------------------------------------------------------------------------------
  
  DataSection
    VT_ActiveScriptSiteInterruptPoll:
    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
      *This\cntRef + 1
      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)
    
    *This\cntRef - 1
    If *This\cntRef < 1
      Debug "ActiveScriptSiteWindow - Release() : Destroy Object", #DebugLevelActiveScript
      FreeStructure(*This)
      ProcedureReturn 0
    Else
      Debug "ActiveScriptSiteWindow - Release() : Refcount = " + Str(*This\cntRef + 1) + " > " + Str(*This\cntRef), #DebugLevelActiveScript
      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
      Debug "New ActiveScriptSiteWindow - Allocate Object", #DebugLevelActiveScriptEx
      *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
    *ActiveScriptInterruptPoll.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
      *this\cntRef + 1
      *Object\i = *this
      ProcedureReturn #S_OK
      
    ElseIf CompareMemory(*iid, ?IID_IActiveScriptSite, 16)
      ; ActiveScriptSite
      Debug "ActiveScriptSite - QueryInterface() : IActiveScriptSite -> Ok", #DebugLevelActiveScript
      *this\cntRef + 1
      *Object\i = *this
      ProcedureReturn #S_OK
      
    ElseIf CompareMemory(*iid, ?IID_IActiveScriptSiteWindow, 16)
      ; ActiveScriptSiteWindow - Objekt zuweisen
      If *this\ActiveScriptSiteWindow = 0
        *this\ActiveScriptSiteWindow = ActiveScriptSiteWindow::New()
        If *this\ActiveScriptSiteWindow
          Debug "ActiveScriptSite - QueryInterface() : IActiveScriptSiteWindow -> New", #DebugLevelActiveScript
          ProcedureReturn #S_OK
        Else
          Debug "ActiveScriptSite - QueryInterface() : IActiveScriptSiteWindow -> Out of Memory", #DebugLevelActiveScript
          ProcedureReturn #E_OUTOFMEMORY
        EndIf
      Else
        Debug "ActiveScriptSite - QueryInterface() : IActiveScriptSiteWindow -> Ok", #DebugLevelActiveScript
        *this\ActiveScriptSiteWindow\AddRef()
        *Object\i = *this\ActiveScriptSiteWindow
        ProcedureReturn #S_OK
      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\ActiveScriptInterruptPoll = 0
        *this\ActiveScriptInterruptPoll = ActiveScriptInterruptPull::New()
        If *this\ActiveScriptInterruptPoll
          Debug "ActiveScriptSite - QueryInterface() : IActiveScriptSiteInterruptPoll -> New", #DebugLevelActiveScript
          ProcedureReturn #S_OK
        Else
          Debug "ActiveScriptSite - QueryInterface() : IActiveScriptSiteInterruptPoll -> Out of Memory", #DebugLevelActiveScript
          ProcedureReturn #E_OUTOFMEMORY
        EndIf
      Else
        Debug "ActiveScriptSite - QueryInterface() : IActiveScriptSiteInterruptPoll -> Ok", #DebugLevelActiveScript
        *this\ActiveScriptInterruptPoll\AddRef()
        *Object\i = *this\ActiveScriptInterruptPoll
        ProcedureReturn #S_OK
      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
    *this\cntRef - 1
    If *this\cntRef < 1
      If *this\ActiveScriptInterruptPoll
        Repeat
          hr = *this\ActiveScriptInterruptPoll\Release()
        Until hr = 0
      EndIf
      If *this\ActiveScriptSiteWindow
        Repeat
          hr = *this\ActiveScriptSiteWindow\Release()
        Until hr = 0
      EndIf
      Debug "ActiveScriptSite - Release() : Destroy Object", #DebugLevelActiveScript
      FreeStructure(*this)
      ProcedureReturn 0
    Else
      Debug "ActiveScriptSite - Release() : Refcount = " + Str(*This\cntRef + 1) + " > " + Str(*This\cntRef), #DebugLevelActiveScript
      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)
    
    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 + "SourceLine: " + 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
      Debug "ActiveScriptSite - Allocate Object", #DebugLevelActiveScriptEx
      *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
      Debug "NewActiveScript - AllocateStructure()", #DebugLevelActiveScriptEx
      *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
      Debug "NewActiveScript - CLSIDFromProgID : ActiveScript(" + Script + ")", #DebugLevelActiveScriptEx
      hr = CLSIDFromProgID_(@Script, @ClsId)
      If hr <> #S_OK
        LastError = hr
        FreeStructure(*Control)
        ProcedureReturn 0
      EndIf
      
      ; Instanz der Scriptengine erstellen
      Debug "NewActiveScript - CoCreateInstance : ActiveScript", #DebugLevelActiveScriptEx
      hr = CoCreateInstance_(@ClsId, 0, 1, ?IID_IActiveScript, @\ActiveScript)
      If hr <> #S_OK
        LastError = hr
        FreeStructure(*Control)
        ProcedureReturn 0
      EndIf
      
      hr = \ActiveScript\AddRef()
      Debug "NewActiveScript - ActiveScript.AddRef() : RefCount " + hr, #DebugLevelActiveScriptEx
      
      ; Parseinterface der Scriptengine suchen
      Debug "NewActiveScript - ActiveScript.QueryInterface() : ActiveScriptParse", #DebugLevelActiveScriptEx
      hr = \ActiveScript\QueryInterface(?IID_IActiveScriptParse, @\ActiveScriptParse)
      If hr <> #S_OK
        LastError = hr
        \ActiveScript\Release()
        FreeStructure(*Control)
        ProcedureReturn 0
      EndIf
      
      ; Object für Scriptsite erstellen
      Debug "NewActiveScript - CreateObject() : ActiveScriptSide", #DebugLevelActiveScriptEx
      \ActiveScriptSite = ActiveScriptSite::New(*Control)
      If \ActiveScriptSite
        \ActiveScriptSite\AddRef()
      Else
        LastError = #E_UNEXPECTED
        \ActiveScriptParse\Release()
        \ActiveScript\Release()
        FreeStructure(*Control)
        ProcedureReturn 0
      EndIf
      
      ; Scriptsite zuweisen
      Debug "NewActiveScript - ActiveScript.SetScriptSide()", #DebugLevelActiveScriptEx
      hr = \ActiveScript\SetScriptSite(\ActiveScriptSite)
      If hr <> #S_OK
        LastError = hr
        \ActiveScriptSite\Release()
        \ActiveScriptParse\Release()
        \ActiveScript\Release()
        FreeStructure(*Control)
        ProcedureReturn 0
      EndIf
      
      ; Parseinterface initialisieren
      Debug "NewActiveScript - ActiveScriptParse.InitNew()", #DebugLevelActiveScriptEx
      hr = \ActiveScriptParse\InitNew()
      If hr <> #S_OK
        LastError = hr
        \ActiveScriptSite\Release()
        \ActiveScriptParse\Release()
        \ActiveScript\Release()
        FreeStructure(*Control)
        ProcedureReturn 0
      EndIf
      
      ; Script Engine Starten
      Debug "NewActiveScript - ActiveScript.SetScriptState()", #DebugLevelActiveScriptEx
      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
      Debug "NewActiveScript - ActiveScript.AddNamedItem() : Object Runtime", #DebugLevelActiveScriptEx
      AddNamedObject(*Control, "Runtime", ActiveScriptRuntime::New())
      
      ProcedureReturn *Control
    EndWith
    
  EndProcedure
  
  ; -----------------------------------------------------------------------------------
  
  Procedure FreeActiveScript(*Control.objActiveScriptControl)
    Protected hr
    
    With *Control
      If \ActiveScriptParse
        hr = \ActiveScriptParse\AddRef()
        Debug "FreeActiveScript - ActiveScriptParse.AddRef() : RefCount " + hr, #DebugLevelActiveScriptEx
        Repeat
          hr = \ActiveScriptParse\Release()
          Debug "FreeActiveScript - ActiveScriptParse.Release() : RefCount " + hr, #DebugLevelActiveScriptEx
        Until hr <= 2
      EndIf
      Debug "FreeActiveScript - Release ActiveScriptSide", #DebugLevelActiveScriptEx
      If \ActiveScriptSite
        Repeat
          hr = \ActiveScriptSite\Release()
        Until hr = 0
      EndIf
      If \ActiveScript
        hr = \ActiveScript\AddRef()
        Debug "FreeActiveScript - ActiveScript.AddRef() : RefCount " + hr, #DebugLevelActiveScriptEx
        Repeat
          hr =  \ActiveScript\Release()
          Debug "FreeActiveScript - ActiveScript.Release() : RefCount " + hr, #DebugLevelActiveScriptEx
        Until hr <= 1
      EndIf
      Debug "FreeActiveScript - Release all NamedItems", #DebugLevelActiveScriptEx
      ForEach \NamedItems()
        Repeat
          hr = \NamedItems()\Object\Release()
        Until hr = 0
      Next
      Debug "FreeActiveScript - FreeStructure()", #DebugLevelActiveScriptEx
      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

; ***************************************************************************************
[/size]
Last edited by mk-soft on Fri Jul 24, 2020 12:15 pm, edited 33 times in total.
My Projects ThreadToGUI / OOP-BaseClass / EventDesigner V3
PB v3.30 / v5.75 - OS Mac Mini OSX 10.xx - VM Window Pro / Linux Ubuntu
Downloads on my Webspace / OneDrive
User avatar
mk-soft
Always Here
Always Here
Posts: 5335
Joined: Fri May 12, 2006 6:51 pm
Location: Germany

Re: Module ActiveScript for VB-Script with PB-Runtime Variab

Post by mk-soft »

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

Update v2.04
- Change ClearSmarttags(...) - Tag name optional for clear all SmartTags

AddON SmartTags

Code: Select all

;-TOP

; Comment   : Modul ActiveScript AddOn SmartTags of type Variant (Case Sensisive)
; Author    : mk-soft
; Version   : v2.04
; Create    : 15.09.2018
; Update    : 02.01.2020
; 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)
    
    *This\cntRef - 1
    If *This\cntRef < 1
      Debug "SmartTags - Release() : Destroy Object", #DebugLevelSmartags
      FreeStructure(*This)
      ProcedureReturn 0
    Else
      Debug "SmartTags - Release() : Refcount = " + Str(*This\cntRef + 1) + " > " + Str(*This\cntRef), #DebugLevelSmartags
      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 = "")
    LockMutex(MutexSmartTags)
    If Bool(Tag)
      If FindMapElement(SmartTags(), Tag)
        VariantClear_(@SmartTags())
        DeleteMapElement(SmartTags())
      EndIf
    Else
      ForEach SmartTags()
        VariantClear_(@SmartTags())
      Next
      ClearMap(SmartTags())
    EndIf
    UnlockMutex(MutexSmartTags)
  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

; ***************************************************************************************
[/size]
Last edited by mk-soft on Thu Jan 02, 2020 7:02 pm, edited 11 times in total.
My Projects ThreadToGUI / OOP-BaseClass / EventDesigner V3
PB v3.30 / v5.75 - OS Mac Mini OSX 10.xx - VM Window Pro / Linux Ubuntu
Downloads on my Webspace / OneDrive
User avatar
mk-soft
Always Here
Always Here
Posts: 5335
Joined: Fri May 12, 2006 6:51 pm
Location: Germany

Re: Module ActiveScript for VB-Script with PB-Runtime Variab

Post by mk-soft »

Simple Variant and SafeArray Helper

Update v1.02r2
- Added SafeArrayToArray
- Added SafeArrayToList

Update v2.03
- Optimize code

Update v2.04
- Remove Debug Output

Update v2.05.1
- Added Simple PB Array from and to Variant

Update v2.06.1
- Added Simple PB List from and to Variant

VariantHelper.pb

Code: Select all

;-TOP

; Comment   : Variant and SafeArray Helper Include
; Author    : mk-soft
; Version   : v2.06.1
; Create    : 23.09.2018
; Update    : 09.12.2021
; 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 IsVariantVarArray(*Value.variant)
  If *Value And *Value\vt & #VT_ARRAY
    ProcedureReturn #True
  Else
    ProcedureReturn #False
  EndIf
EndProcedure

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

; ----

Procedure.s GetVariantString(*Value.Variant)
  Protected hr, result.s, VarDest.Variant
  If *Value
    If *Value\vt = #VT_BSTR
      ProcedureReturn PeekS(*Value\bstrVal, #PB_Any, #PB_Unicode)
    Else
      hr = VariantChangeType_(VarDest, *Value, 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(*Value.Variant)
  Protected hr, result.i, VarDest.Variant
  If *Value
    CompilerSelect #PB_Compiler_Processor
      CompilerCase #PB_Processor_x86
        If *Value\vt = #VT_I4
          ProcedureReturn *Value\lVal
        Else
          hr = VariantChangeType_(VarDest, *Value, 0, #VT_I4)
          If hr = #S_OK
            result = VarDest\lVal
            VariantClear_(VarDest)
          EndIf
        EndIf
      CompilerCase #PB_Processor_x64
        If *Value\vt = #VT_I8
          ProcedureReturn *Value\llVal
        Else
          hr = VariantChangeType_(VarDest, *Value, 0, #VT_I8)
          If hr = #S_OK
            result = VarDest\llVal
            VariantClear_(VarDest)
          EndIf
        EndIf
    CompilerEndSelect
  EndIf
  ProcedureReturn result
EndProcedure

; ----

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

; ----

Procedure.i GetVariantDate(*Value.Variant) ; Result PB-Date from Variant Date
  Protected hr, result, VarDest.Variant
  If *Value
    hr = VariantChangeType_(VarDest, *Value, 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(*Value.Variant)
  Protected hr, result, VarDest.Variant
  If *Value
    hr = VariantChangeType_(VarDest, *Value, 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(*Value.Variant)
  Protected *psa
  If *Value
    If *Value\vt & #VT_ARRAY
      If *Value\vt & #VT_BYREF
        *psa = *Value\pparray\i
      Else
        *psa = *Value\parray
      EndIf
    EndIf
  EndIf
  ProcedureReturn *psa
EndProcedure

; ----

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

; ----

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

; ----

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

; ----

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

; ----

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

; ----

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

; ----

Procedure FreeStructureVariant(*Value.Variant)
  If *Value
    VariantClear_(*Value)
    FreeStructure(*Value)
  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, Size
  
  Size = ArraySize(Strings())
  rgsabound\lLbound = LBound
  rgsabound\cElements = Size + 1
  
  *psa = SafeArrayCreate_(#VT_VARIANT, 1, rgsabound)
  If *psa
    For Index = 0 To size
      *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
        *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

; ++++

;- PB Array To Variant Array. Only 1 Dims

Procedure StringArrayToVariant(Array String.s(1), *Value.Variant)
  Protected rgsabound.SAFEARRAYBOUND, *psa.SAFEARRAY, Index, Size
  
  If Not *Value
    ProcedureReturn 0
  EndIf
  
  VariantClear_(*Value)
  
  Size = ArraySize(String())
  rgsabound\lLbound = 0
  rgsabound\cElements = Size + 1
  *psa = SafeArrayCreate_(#VT_VARIANT, 1, rgsabound)
  If *psa
    For Index = 0 To Size
      *psa\pvData\Value[Index]\vt = #VT_BSTR
      *psa\pvData\Value[Index]\bstrVal = SysAllocString_(String(Index))
    Next
    *Value\vt = #VT_ARRAY | #VT_VARIANT
    *Value\parray = *psa
    ProcedureReturn *Value
  Else
    ProcedureReturn 0
  EndIf
EndProcedure

Procedure DoubleArrayToVariant(Array Double.d(1), *Value.Variant)
  Protected rgsabound.SAFEARRAYBOUND, *psa.SAFEARRAY, Index, Size
  
  If Not *Value
    ProcedureReturn 0
  EndIf
  
  VariantClear_(*Value)
  
  Size = ArraySize(Double())
  rgsabound\lLbound = 0
  rgsabound\cElements = Size + 1
  *psa = SafeArrayCreate_(#VT_VARIANT, 1, rgsabound)
  If *psa
    For Index = 0 To Size
      *psa\pvData\Value[Index]\vt = #VT_R8
      *psa\pvData\Value[Index]\dblVal = Double(Index)
    Next
    *Value\vt = #VT_ARRAY | #VT_VARIANT
    *Value\parray = *psa
    ProcedureReturn *Value
  Else
    ProcedureReturn 0
  EndIf
EndProcedure

Procedure IntegerArrayToVariant(Array Integer.i(1), *Value.Variant)
  Protected rgsabound.SAFEARRAYBOUND, *psa.SAFEARRAY, Index, Size
  
  If Not *Value
    ProcedureReturn 0
  EndIf
  
  VariantClear_(*Value)
  
  Size = ArraySize(Integer())
  rgsabound\lLbound = 0
  rgsabound\cElements = Size + 1
  *psa = SafeArrayCreate_(#VT_VARIANT, 1, rgsabound)
  If *psa
    CompilerIf #PB_Compiler_Processor = #PB_Processor_x64
      For Index = 0 To Size
        *psa\pvData\Value[Index]\vt = #VT_I8
        *psa\pvData\Value[Index]\llVal = Integer(Index)
      Next
    CompilerElse
      For Index = 0 To Size
        *psa\pvData\Value[Index]\vt = #VT_I4
        *psa\pvData\Value[Index]\lVal = Integer(Index)
      Next
    CompilerEndIf
    *Value\vt = #VT_ARRAY | #VT_VARIANT
    *Value\parray = *psa
    ProcedureReturn *Value
  Else
    ProcedureReturn 0
  EndIf
EndProcedure

; ++++

;- Variant Array To PB Array. Only 1 Dims.

Procedure VariantToStringArray(*Value.Variant, Array Dest.s(1))
  Protected *psa.SAFEARRAY, cnt, index, vartype
  
  If *Value And *Value\vt & #VT_ARRAY
    If *Value\vt & #VT_BYREF
      *psa = *Value\pparray\i
    Else
      *psa = *Value\parray
    EndIf
  Else
    ProcedureReturn 0
  EndIf
  
  If *psa And *psa\cDims = 1
    If SafeArrayGetVartype_(*psa, @vartype) = #S_OK
      If vartype = #VT_VARIANT
        cnt = *psa\rgsabound[0]\cElements - 1
        Dim Dest(cnt)
        For index = 0 To cnt
          Dest(index) = GetVariantString(*psa\pvData\Value[index])
        Next
      EndIf
    EndIf
    ProcedureReturn cnt + 1
  Else
    ProcedureReturn 0
  EndIf
EndProcedure

; ----

Procedure VariantToDoubleArray(*Value.Variant, Array Dest.d(1))
  Protected *psa.SAFEARRAY, cnt, index, vartype
  
  If *Value And *Value\vt & #VT_ARRAY
    If *Value\vt & #VT_BYREF
      *psa = *Value\pparray\i
    Else
      *psa = *Value\parray
    EndIf
  Else
    ProcedureReturn 0
  EndIf
  
  If *psa And *psa\cDims = 1
    If SafeArrayGetVartype_(*psa, @vartype) = #S_OK
      If vartype = #VT_VARIANT
        cnt = *psa\rgsabound[0]\cElements - 1
        Dim Dest(cnt)
        For index = 0 To cnt
          Dest(index) = GetVariantDouble(*psa\pvData\Value[index])
        Next
      EndIf
    EndIf
    ProcedureReturn cnt + 1
  Else
    ProcedureReturn 0
  EndIf
EndProcedure

; ----

Procedure VariantToIntegerArray(*Value.Variant, Array Dest.i(1))
  Protected *psa.SAFEARRAY, cnt, index, vartype
  
  If *Value And *Value\vt & #VT_ARRAY
    If *Value\vt & #VT_BYREF
      *psa = *Value\pparray\i
    Else
      *psa = *Value\parray
    EndIf
  Else
    ProcedureReturn 0
  EndIf
  
  If *psa And *psa\cDims = 1
    If SafeArrayGetVartype_(*psa, @vartype) = #S_OK
      If vartype = #VT_VARIANT
        cnt = *psa\rgsabound[0]\cElements - 1
        Dim Dest(cnt)
        For index = 0 To cnt
          Dest(index) = GetVariantInteger(*psa\pvData\Value[index])
        Next
      EndIf
    EndIf
    ProcedureReturn cnt + 1
  Else
    ProcedureReturn 0
  EndIf
EndProcedure

; ----

;- Variant Array To PB List. Only 1 Dims.

Procedure VariantToStringList(*Value.Variant, List Dest.s())
  Protected *psa.SAFEARRAY, cnt, index, vartype
  
  ClearList(Dest())
  
  If *Value And *Value\vt & #VT_ARRAY
    If *Value\vt & #VT_BYREF
      *psa = *Value\pparray\i
    Else
      *psa = *Value\parray
    EndIf
  Else
    ProcedureReturn 0
  EndIf
  
  If *psa And *psa\cDims = 1
    If SafeArrayGetVartype_(*psa, @vartype) = #S_OK
      If vartype = #VT_VARIANT
        cnt = *psa\rgsabound[0]\cElements - 1
        For index = 0 To cnt
          AddElement(Dest())
          Dest() = GetVariantString(*psa\pvData\Value[index])
        Next
      EndIf
    EndIf
    ProcedureReturn cnt + 1
  Else
    ProcedureReturn 0
  EndIf
EndProcedure

; ----

Procedure VariantToDoubleList(*Value.Variant, List Dest.d())
  Protected *psa.SAFEARRAY, cnt, index, vartype
  
  ClearList(Dest())
  
  If *Value And *Value\vt & #VT_ARRAY
    If *Value\vt & #VT_BYREF
      *psa = *Value\pparray\i
    Else
      *psa = *Value\parray
    EndIf
  Else
    ProcedureReturn 0
  EndIf
  
  If *psa And *psa\cDims = 1
    If SafeArrayGetVartype_(*psa, @vartype) = #S_OK
      If vartype = #VT_VARIANT
        cnt = *psa\rgsabound[0]\cElements - 1
        For index = 0 To cnt
          AddElement(Dest())
          Dest() = GetVariantDouble(*psa\pvData\Value[index])
        Next
      EndIf
    EndIf
    ProcedureReturn cnt + 1
  Else
    ProcedureReturn 0
  EndIf
EndProcedure

; ----

Procedure VariantToIntegerList(*Value.Variant, List Dest.i())
  Protected *psa.SAFEARRAY, cnt, index, vartype
  
  ClearList(Dest())
  
  If *Value And *Value\vt & #VT_ARRAY
    If *Value\vt & #VT_BYREF
      *psa = *Value\pparray\i
    Else
      *psa = *Value\parray
    EndIf
  Else
    ProcedureReturn 0
  EndIf
  
  If *psa And *psa\cDims = 1
    If SafeArrayGetVartype_(*psa, @vartype) = #S_OK
      If vartype = #VT_VARIANT
        cnt = *psa\rgsabound[0]\cElements - 1
        For index = 0 To cnt
          AddElement(Dest())
          Dest() = GetVariantInteger(*psa\pvData\Value[index])
        Next
      EndIf
    EndIf
    ProcedureReturn cnt + 1
  Else
    ProcedureReturn 0
  EndIf
EndProcedure

; ----

; ***************************************************************************************
[/size]
Last edited by mk-soft on Thu Dec 09, 2021 8:38 pm, edited 10 times in total.
My Projects ThreadToGUI / OOP-BaseClass / EventDesigner V3
PB v3.30 / v5.75 - OS Mac Mini OSX 10.xx - VM Window Pro / Linux Ubuntu
Downloads on my Webspace / OneDrive
User avatar
mk-soft
Always Here
Always Here
Posts: 5335
Joined: Fri May 12, 2006 6:51 pm
Location: Germany

Re: Module ActiveScript for VB-Script with PB-Runtime Variab

Post by mk-soft »

Update v1.04 Beta
- Bugfix QueryInterface IActiveScriptSiteWindow
- Fixed RefCounter

More debugging on level 2 :wink:
My Projects ThreadToGUI / OOP-BaseClass / EventDesigner V3
PB v3.30 / v5.75 - OS Mac Mini OSX 10.xx - VM Window Pro / Linux Ubuntu
Downloads on my Webspace / OneDrive
User avatar
Kwai chang caine
Always Here
Always Here
Posts: 5342
Joined: Sun Nov 05, 2006 11:42 pm
Location: Lyon - France

Re: Module ActiveScript for VB-Script with PB-Runtime Variab

Post by Kwai chang caine »

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:
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()
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
User avatar
mk-soft
Always Here
Always Here
Posts: 5335
Joined: Fri May 12, 2006 6:51 pm
Location: Germany

Re: Module ActiveScript for VB-Script with PB-Runtime Variab

Post by mk-soft »

New Example with SafeArray to VB-Script :wink:

Update v2.01
- Used new VariantHelper.pb

Code: Select all

;-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")
[/size]
Last edited by mk-soft on Sun May 26, 2019 1:23 pm, edited 4 times in total.
My Projects ThreadToGUI / OOP-BaseClass / EventDesigner V3
PB v3.30 / v5.75 - OS Mac Mini OSX 10.xx - VM Window Pro / Linux Ubuntu
Downloads on my Webspace / OneDrive
User avatar
mk-soft
Always Here
Always Here
Posts: 5335
Joined: Fri May 12, 2006 6:51 pm
Location: Germany

Re: Module ActiveScript for VB-Script with PB-Runtime Variab

Post by mk-soft »

Example 2 - SafeArray Direct Access

Update v2.01

Code: Select all

;-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
[/size]
Last edited by mk-soft on Sun May 26, 2019 1:24 pm, edited 4 times in total.
My Projects ThreadToGUI / OOP-BaseClass / EventDesigner V3
PB v3.30 / v5.75 - OS Mac Mini OSX 10.xx - VM Window Pro / Linux Ubuntu
Downloads on my Webspace / OneDrive
User avatar
Kwai chang caine
Always Here
Always Here
Posts: 5342
Joined: Sun Nov 05, 2006 11:42 pm
Location: Lyon - France

Re: Module ActiveScript for VB-Script with PB-Runtime Variab

Post by Kwai chang caine »

Thanks for sharing 8)
ImageThe happiness is a road...
Not a destination
User avatar
mk-soft
Always Here
Always Here
Posts: 5335
Joined: Fri May 12, 2006 6:51 pm
Location: Germany

Re: Module ActiveScript for VB-Script with PB-Runtime Variab

Post by mk-soft »

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: Select all

;-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
[/size]
Last edited by mk-soft on Sun May 26, 2019 1:26 pm, edited 2 times in total.
My Projects ThreadToGUI / OOP-BaseClass / EventDesigner V3
PB v3.30 / v5.75 - OS Mac Mini OSX 10.xx - VM Window Pro / Linux Ubuntu
Downloads on my Webspace / OneDrive
User avatar
mk-soft
Always Here
Always Here
Posts: 5335
Joined: Fri May 12, 2006 6:51 pm
Location: Germany

Re: Module ActiveScript for VB-Script with PB-Runtime Variab

Post by mk-soft »

Update v2.01
- Added Runtime.Sleep [milliseconds]

WScript.Shell not longer support sleep...

Example 4 - Load Webpage over Internet-Explorer

Code: Select all

;-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
[/size]
Last edited by mk-soft on Sun May 26, 2019 1:28 pm, edited 1 time in total.
My Projects ThreadToGUI / OOP-BaseClass / EventDesigner V3
PB v3.30 / v5.75 - OS Mac Mini OSX 10.xx - VM Window Pro / Linux Ubuntu
Downloads on my Webspace / OneDrive
zikitrake
Addict
Addict
Posts: 834
Joined: Thu Mar 25, 2004 2:15 pm
Location: Spain

Re: Module ActiveScript for VB-Script with PB-Runtime Variab

Post by zikitrake »

mk-soft wrote:Update v1.06
- Added Runtime.Sleep [milliseconds]

WScript.Shell not longer support sleep...

Example 4 - Load Webpage over Internet-Explorer

Code: Select all

;-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
[/size]
Hi! I got this error with the last sample (Windows 10x64, PB 5.70x64)

https://prnt.sc/l8mwoe
User avatar
mk-soft
Always Here
Always Here
Posts: 5335
Joined: Fri May 12, 2006 6:51 pm
Location: Germany

Re: Module ActiveScript for VB-Script with PB-Runtime Variab

Post by mk-soft »

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 / EventDesigner V3
PB v3.30 / v5.75 - OS Mac Mini OSX 10.xx - VM Window Pro / Linux Ubuntu
Downloads on my Webspace / OneDrive
User avatar
Kiffi
Addict
Addict
Posts: 1353
Joined: Tue Mar 02, 2004 1:20 pm
Location: Amphibios 9

Re: Module ActiveScript for VB-Script with PB-Runtime Variab

Post by Kiffi »

no problems here either (Windows 10 pro)
Hygge
zikitrake
Addict
Addict
Posts: 834
Joined: Thu Mar 25, 2004 2:15 pm
Location: Spain

Re: Module ActiveScript for VB-Script with PB-Runtime Variab

Post by zikitrake »

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
zikitrake
Addict
Addict
Posts: 834
Joined: Thu Mar 25, 2004 2:15 pm
Location: Spain

Re: Module ActiveScript for VB-Script with PB-Runtime Variab

Post by zikitrake »

:shock: Okay, the problem is on my team.
I recorded the script in a.vbs file and executed it on the command line:

Code: Select all

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!
Post Reply