Module ActiveScript for VBScript and JScript with PB-Runtime Variables

[mk-soft]

Update v2.12
- Bugfix ActiveScript Release

Oops, I had one Object.Release() too many.
Furthermore, I set the debug output to #DebugLevel = 6 (#DebugLevelActiveScriptEx) to display all debug outputs.

As it looks now all reference counters of all objects are correct

[mk-soft]

Update v2.13
- Added InterruptScriptThread
- Added SetScriptErrorCallback
- Added SetScriptTraceCallback

Example running script in thread and interrupt the script
Update

Code: Select all

;-TOP

; Comment   : Modul ActiveScript Example ScriptThread
; Version   : v2.13

; 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

CompilerIf Not #PB_Compiler_Thread
  CompilerError "Use Compiler Option ThreadSafe!"
CompilerEndIf

Procedure.s FormatMessage(ErrorCode.l) 
  Protected *Buffer, len, result.s 
  len = FormatMessage_(#FORMAT_MESSAGE_ALLOCATE_BUFFER|#FORMAT_MESSAGE_FROM_SYSTEM,0,ErrorCode,0,@*Buffer,0,0) 
  If len 
    result = PeekS(*Buffer) 
    LocalFree_(*Buffer) 
    ProcedureReturn result 
  Else 
    ProcedureReturn "Errorcode: " + Hex(ErrorCode, #PB_Long) 
  EndIf 
EndProcedure 

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

Global MutexScriptError = CreateMutex()
Global MutexScriptTrace = CreateMutex()

Procedure MyScriptErrorCB(ErrorText.s)
  LockMutex(MutexScriptError)
  Debug "-------------------------"
  Debug ErrorText
  Debug "-------------------------"
  MessageRequester("ActiveScriptSite - OnScriptError", ErrorText, #PB_MessageRequester_Error)
  UnlockMutex(MutexScriptError)
EndProcedure

Procedure MyScriptTraceCB(TraceText.s)
  LockMutex(MutexScriptTrace)
  Debug FormatDate("[%hh:%ii:%ss] ", Date()) + TraceText
  UnlockMutex(MutexScriptTrace)
EndProcedure

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

Structure udtMyScriptThread
  ThreadID.i
  Control.i
  vbs.s
  result.s
EndStructure

Procedure MyScriptThread(*Data.udtMyScriptThread)
  
  With *Data
    \Control = NewActiveScript()
    If \Control
      AddNamedObject(\Control, "SmartTags", NewSmartTags())
      SetScriptErrorCallback(\Control, @MyScriptErrorCB())
      SetScriptTraceCallback(\Control, @MyScriptTraceCB())
      ParseScriptText(\Control, \vbs)
      \result = GetVariantString(SmartTags("result"))
      FreeActiveScript(\Control)
      \Control = 0
    EndIf
  EndWith
  
EndProcedure

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

Procedure.s GetDataSectionText(*Addr.Character)
  Protected result.s, temp.s
  While *Addr\c <> #ETX
    temp = PeekS(*Addr)
    *Addr + StringByteLength(temp) + SizeOf(Character)
    result + temp + #LF$
  Wend
  ProcedureReturn result
EndProcedure

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

Global MyScriptData.udtMyScriptThread

With MyScriptData
  Debug "*** Start Thread ***"
  \vbs = GetDataSectionText(?vbs)
  \ThreadID = CreateThread(@MyScriptThread(), @MyScriptData)
  Debug "*** Delay ***"
  Delay(3000)
  If IsThread(\ThreadID)
    Debug "*** Interrupt Script ***"
    r1 = InterruptScriptThread(\Control)
    Debug FormatMessage(r1)
    Delay(1000)
  EndIf
  If WaitThread(\ThreadID, 6000) = 0
    Debug "*** Kill Thread ***"
    KillThread(\ThreadID)
  EndIf
  Debug "*** Ready Result " + \result + " ***"
EndWith

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

DataSection
  vbs:
  Data.s ~"Dim i"
  Data.s ~""
  Data.s ~"For i = 1 to 10"
  Data.s ~"  runtime.trace \"Loop \" & i"
  Data.s ~"  runtime.sleep 500"
  Data.s ~"Next"
  Data.s ~""
  Data.s ~"smarttags.text(\"result\") = \"Done.\""
  Data.s ~""
  Data.s ~""
  Data.s ~""
  Data.s ~""
  Data.s ~"runtime.trace \"Finished\""
  Data.s #ETX$
  Data.i 0
EndDataSection

[mk-soft]

Update v2.14
- Added ParseScriptText with optional parameter vResult as variant
- Run script as expression

Example GetFileInfo

Code: Select all

;-TOP

; Comment   : Modul ActiveScript Example GetFileInfo
; Version   : v2.14

; 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

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

Procedure.s GetDataSectionText(*Addr.Character)
  Protected result.s, temp.s
  While *Addr\c <> #ETX
    temp = PeekS(*Addr)
    *Addr + StringByteLength(temp) + SizeOf(Character)
    result + temp + #LF$
  Wend
  ProcedureReturn result
EndProcedure

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

Global sFile.s, sDir.s
Global Dim Result.s(0)

Runtime sFile, sDir

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

Procedure LoadScript(vbScript.s)
  Protected *Control

  *Control = NewActiveScript()
  If *Control
    ;AddNamedObject(*Control, "SmartTags", NewSmartTags())
    r1 = ParseScriptText(*Control, vbScript)
  EndIf
  ProcedureReturn *Control
EndProcedure

Procedure ExecuteScript(*Control, Gadget, StatusBar)
  Protected FileName.s, vResult.VARIANT
  
  FileName = OpenFileRequester("Select File", "", "", 0)
  If FileName
    ClearGadgetItems(Gadget)
    StatusBarText(StatusBar, 0, FileName)
    sDir = GetPathPart(FileName)
    sFile = GetFilePart(FileName)
    r1 = ParseScriptText(*Control, ~"GetFileInfo(Runtime.String(\"sDir\"), Runtime.String(\"sFile\"))", #SCRIPTTEXT_ISEXPRESSION, vResult)
    If r1 = #S_OK
      VariantToStringArray(vResult, Result())
      For i = 0 To ArraySize(Result())
        AddGadgetItem(Gadget, -1, Result(i))
      Next
      VariantClear(vResult)
    EndIf
  EndIf
EndProcedure

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

;-GUI

Procedure UpdateWindow()
  Protected dx, dy
  dx = WindowWidth(0)
  dy = WindowHeight(0) - StatusBarHeight(0) - MenuHeight()
  ; Resize Gadgets
  ResizeGadget(0, 5, 5, dx - 10, dy - 10)
EndProcedure

Procedure Main()
  Protected dx, dy
  Protected *Control
  
  #WinStyle = #PB_Window_SystemMenu | #PB_Window_SizeGadget | #PB_Window_MaximizeGadget | #PB_Window_MinimizeGadget
  
  If OpenWindow(0, #PB_Ignore, #PB_Ignore, 600, 400, "VB-Script GetFileInfo", #WinStyle)
    ; MenuBar
    CreateMenu(0, WindowID(0))
    MenuTitle("File")
    MenuItem(0, "Open")
    MenuBar()
    MenuItem(99, "Exit")
    
    ; StatusBar
    CreateStatusBar(0, WindowID(0))
    AddStatusBarField(#PB_Ignore)
    
    ; Gadgets
    dx = WindowWidth(0)
    dy = WindowHeight(0) - StatusBarHeight(0) - MenuHeight()
    ListIconGadget(0, 5, 5, dx - 10, dy - 10, "Index", 60, #PB_ListIcon_FullRowSelect | #PB_ListIcon_GridLines)
    AddGadgetColumn(0, 1, "Name", 200)
    AddGadgetColumn(0, 2, "Value", 600)
    
    ; Bind Events
    BindEvent(#PB_Event_SizeWindow, @UpdateWindow(), 0)
    
    *Control = LoadScript(GetDataSectionText(?vbs))
    If Not *Control
      MessageRequester("Error", "LoadScript", #PB_MessageRequester_Error)
      End
    EndIf
    
    ; Main Loop
    Repeat
      Select WaitWindowEvent()
        Case #PB_Event_CloseWindow
          Select EventWindow()
            Case 0
              Break
          EndSelect
          
        Case #PB_Event_Menu
          Select EventMenu()
            Case 0
              ExecuteScript(*Control, 0, 0)
            Case 99
              Break
              
          EndSelect
          
        Case #PB_Event_Gadget
          Select EventGadget()
              
          EndSelect
          
      EndSelect
    ForEver
    
    FreeActiveScript(*Control)
    
  EndIf
  
EndProcedure : Main()

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

DataSection
  vbs:
  Data.s ~"On Error Resume Next"
  Data.s ~"Function GetFileInfo(sDir, sFile)"
  Data.s ~" Dim objShell, oFolder, oFile"
  Data.s ~" Dim sPropName, sPropValue"
  Data.s ~" Dim Result(304)"
  Data.s ~" "
  Data.s ~" Set objShell = CreateObject(\"Shell.Application\")"
  Data.s ~" Set oFolder = objShell.Namespace(sDir)"
  Data.s ~" Set oFile = oFolder.ParseName(sFile)"
  Data.s ~" ' Different OS versions support different numbers of supported max entries..."
  Data.s ~" For i = 0 To 304"
  Data.s ~"  sPropName  = oFolder.GetDetailsOf(Null, i)"
  Data.s ~"  sPropValue = oFolder.GetDetailsOf(oFile, i)"
  Data.s ~"  Result(i) =  \"\" & i & vbNewLine & sPropName & vbNewLine & sPropValue"
  Data.s ~" Next"
  Data.s ~" GetFileInfo = Result"
  Data.s ~"End Function"
  Data.s ~" "
  Data.s #ETX$
EndDataSection

[mk-soft]

Update v2.15
- Fixed ActiveScript.AddNamedItem
- Fixes ActiveScriptSite.GetItemInfo

Place of AddRef adjusted

[ricardo]

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

Hi,

Im trying to run this example, but when trying to run:

ParseScriptText(vbs)

I get an error because it ask for more params.

Any help are welcome. Thanks.

[mk-soft]

Hi,

You have copied the old example for version 1.x.
The parameters have changed in version 2.x.

Link for v2.x: https://www.purebasic.fr/english/viewto ... 83#p528183


P.S:

ActiveScript Update v2.16
- Small adjustment

[ricardo]

Hi,

You have copied the old example for version 1.x.
The parameters have changed in version 2.x.

Link for v2.x: https://www.purebasic.fr/english/viewto ... 83#p528183


P.S:

ActiveScript Update v2.16
- Small adjustment

Great, now it works just fine.

Thanks a lot !!

[ricardo]

Hi,

You have copied the old example for version 1.x.
The parameters have changed in version 2.x.

Link for v2.x: https://www.purebasic.fr/english/viewto ... 83#p528183


P.S:

ActiveScript Update v2.16
- Small adjustment

Hi @mk-soft


One question: Why the usage of "vbs + ~"

Thanks

[mk-soft]

One question: Why the usage of "vbs + ~"

See PB Help https://www.purebasic.com/documentation ... rules.html
and literal strings

[ricardo]

One question: Why the usage of "vbs + ~"

See PB Help https://www.purebasic.com/documentation ... rules.html
and literal strings

Ok, thanks, i have not noticed about strings with escape.

Best Regards

[mk-soft]

Update Modul SmartTagsv2.09
- Optimises the SmartTagsMethod object with the parent object SmartTags referenze counter