Module ActiveScript for VBScript and JScript with PB-Runtime Variables

[mk-soft]

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

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

[mk-soft]

Update v2.08
- Bugfix ActiveScriptSite -> OnScriptError

The passed object 'ScriptError' must not be released within the object.

[mk-soft]

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

Set the debug level to #DebugLevelRuntimeTrace to get only the output of VBS Runtime.Trace <Value>.

VariantHelper Update v2.04
- Remove Debug Output

[mk-soft]

Small example with Sub and Functions ...

Code: Select all

;-TOP

; Comment   : Modul ActiveScript Example 12
; Version   : v2.09

; 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 vbs.s, sValue1.s, sValue2.s

Runtime sValue1, sValue2

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

vbs = GetDataSectionText(?vbs)

Debug "*** New ActiveScript ***"
*Control = NewActiveScript()
If *Control
  Debug "*** Add Object SmartTags ***"
  AddNamedObject(*Control, "SmartTags", NewSmartTags())
  Debug "*** Parse ScriptText Sub and Functions***"
  r1 = ParseScriptText(*Control, vbs)
  If r1 = #S_OK
    Debug "Code Ready 1."
  EndIf
  
  sValue1 = "Hello World!"
  r1 = ParseScriptText(*Control, ~"SetValue(Runtime.String(\"sValue1\"))")
  If r1 = #S_OK
    Debug "Code Ready 2."
  EndIf
  
  r1 = ParseScriptText(*Control, ~"Runtime.String(\"sValue2\") = GetValue()")
  If r1 = #S_OK
    Debug "Code Ready 3."
  EndIf
  Debug "Result = " + sValue2
  
  Debug "*** Free ActiveScript ***"
  FreeActiveScript(*Control)
  Debug "*** Finished ActiceScript ***"

  Debug "************************************************************"
EndIf
; -------------------------------------------------------------------------------------

DataSection
  vbs:
  Data.s ~"On Error Resume Next"
  Data.s ~""
  Data.s ~"Public TextValue"
  Data.s ~""
  Data.s ~"Sub SetValue(Value)"
  Data.s ~" TextValue = Value"
  Data.s ~" Runtime.Trace \"Sub SetValue \" & Value"
  Data.s ~"End Sub"
  Data.s ~""
  Data.s ~"Function GetValue()"
  Data.s ~" GetValue = Ucase(TextValue)"
  Data.s ~"End Function"
  Data.s ~""
  Data.s ~""
  Data.s ~""
  Data.s #ETX$
  Data.i 0
EndDataSection

[mk-soft]

Update VariantHelper v2.05
- Added: Simple PB Arrays from and to Variant (SmartTags)

Update VariantHelper v2.05.1
- Optimize

Example

Code: Select all

;-TOP

; Comment   : Modul ActiveScript Example 15
; Version   : v2.09

; 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 script.s

Dim TextList.s(3)
TextList(0) = "****"
TextList(1) = "Hello World"
TextList(2) = "I like Purebasic"
TextList(3) = "****"

Dim Values.d(2)
Values(0) = 100.0
Values(1) = 200.0
Values(2) = 50.5

Dim Result.i(0)

*Control = NewActiveScript()
If *Control
  ; AddOn SmartTags hinzufügen
  AddNamedObject(*Control, "SmartTags", NewSmartTags())
  
  Debug "*** Parse ScriptText ***"
  
  script = GetDataSectionText(?vbs)
  
  StringArrayToVariant(TextList(), SmartTags("TextList"))
  DoubleArrayToVariant(Values(), SmartTags("Values"))
  
  r1 = ParseScriptText(*Control, script)
  If r1 = #S_OK
    Debug "Code Ready."
  EndIf
  
  Debug "* List *"
  If IsVariantVarArray(SmartTags("List"))
    If VariantToStringArray(SmartTags("List"), TextList())
      For i = 0 To ArraySize(TextList())
        Debug TextList(i)
      Next
    EndIf
  EndIf
  
  Debug "* Result *"
  If IsVariantVarArray(SmartTags("Result"))
    If VariantToIntegerArray(SmartTags("Result"), Result())
      For i = 0 To ArraySize(Result())
        Debug Result(i)
      Next
    EndIf
  EndIf
  
  
  Debug "*** Free ActiveScript ***"
  FreeActiveScript(*Control)
  
  Debug "************************************************************"
EndIf

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

DataSection
  vbs:
  Data.s ~"'On Error Resume Next"
  Data.s ~""
  Data.s ~"Dim r1, textlist, text, sum, values, value"
  Data.s ~""
  Data.s ~"textlist = SmartTags(\"TextList\")"
  Data.s ~"values = SmartTags(\"Values\")"
  Data.s ~""
  Data.s ~"If IsArray(textlist) Then"
  Data.s ~"  For Each text in textlist"
  Data.s ~"    r1 = r1 + text + vbNewLine"
  Data.s ~"  Next"
  Data.s ~"Else"
  Data.s ~"  msgbox \"No Array\""
  Data.s ~"End If"
  Data.s ~"If IsArray(values) Then"
  Data.s ~"  For Each value in values"
  Data.s ~"    sum = sum + value"
  Data.s ~"  Next"
  Data.s ~"Else"
  Data.s ~"  msgbox \"No Array\""
  Data.s ~"End If"
  Data.s ~"msgbox r1 & vbNewline & sum"
  Data.s ~""
  Data.s ~"Dim i, list(10), result(10)"
  Data.s ~""
  Data.s ~"For i = 0 to 10"
  Data.s ~" list(i) = \"Counter \" & i"
  Data.s ~" result(i) = 100 + i"
  Data.s ~"Next"
  Data.s ~""
  Data.s ~"' Update SmartTags"
  Data.s ~"SmartTags(\"List\") = list"
  Data.s ~"SmartTags(\"Result\") = result"
  Data.s ~""
  Data.s #ETX$
  Data.i 0
EndDataSection

[Kwai chang caine]

Thanks for all this great job
Two last examples works fine here, thanks for sharing

[Derren]

Hi mk-soft,

is there any way I can use the 32bit version of the scripting host?

I'm trying the following VBS code, that I found online, to access a Microsoft Access accdb file.

Code: Select all

Set conn = CreateObject("ADODB.Connection")
' Connect to the database
strConnect = "Provider=Microsoft.ACE.OLEDB.12.0; Data Source=C:\Users\User\Desktop\Database1.accdb"
conn.Open strConnect
MsgBox conn
StrSQL = "Select * from Tabelle1"
Set rs = conn.Execute(StrSQL)
Do While Not rs.EOF
    MsgBox "Spalte1:" & rs.Fields("Spalte1") & " Spalte2:"& rs.Fields("Spalte2")
    rs.MoveNext
Loop

Here's the PB-Code using your include:

Code: Select all

IncludeFile "ActiveScript.pbi"

vbs.s = "" + 
~"Set conn = CreateObject(\"ADODB.Connection\")"+#CRLF$+
~"' Connect to the database"+#CRLF$+
~"strConnect = \"Provider=Microsoft.ACE.OLEDB.12.0; Data Source=C:\\Users\\User\\Desktop\\Database1.accdb\""+#CRLF$+
~"conn.Open strConnect"+#CRLF$+
~"MsgBox conn"+#CRLF$+

~"StrSQL = \"Select * from Tabelle1\""+#CRLF$+
~"Set rs = conn.Execute(StrSQL)"+#CRLF$+
~"Do While Not rs.EOF"+#CRLF$+
~"    MsgBox \"Spalte1:\" & rs.Fields(\"Spalte1\") & \" Spalte2:\"& rs.Fields(\"Spalte2\")"+#CRLF$+
~"    rs.MoveNext"+#CRLF$+
~"Loop"


*Control = ActiveScript::NewActiveScript()
If *Control
  ActiveScript::ParseScriptText(*Control, vbs)
  ActiveScript::FreeActiveScript(*Control)
EndIf

Okay, so this VBS-code does not actually work on my machine (says the Provider can not be found) and here is why: https://social.technet.microsoft.com/Fo ... forum=ITCG

The comments there said to use a 32bit scripting host

From a 32 bit prompt:

cscript yourfile.vbs

From a 64 bit prompt:

c:\windows\SysWow64\cscript yourfile.vbs

And NOW, it does indeed work, using the line with the SysWow64 directory.

Is there any way I can do this with your Active Script?

I tried messing about with this part here, exchanging the x86 for the x64 data. But then it did nothing at all.

Code: Select all

    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

Any help would be greatly appreciated. I'm trying for days to get data from an Access-file and nothing seems to work.
Thanks

[mk-soft]

Here there is the same problem as with DLL's. X64 program uses X64 DLL's and X64 COM objects. Similar to X86 programs X86 DLL's and X86 COM objects.
So the problem is that your X64 program also uses the X64 COM objects for ADODB and therefore also the database drivers for X64.


There are two possibilities.
1.
Compile the program with X86 (What you don't want to do)

2.
Install the database drivers for X64.

Download AccessDatabaseEngine Link: https://www.microsoft.com/en-us/downloa ... x?id=54920

I hope this helps you

[Derren]

Thanks. Found the solution of installing drivers on another thread and also in many threads in other forums, but that's no an option on the machines I want to run this software, unfortunately.

[infratec]

Hi Michael,

I run into an IMA at FreeStructureVariant() when I use your VariantHelper.pbi version v2.05.1

Code: Select all

  Protected FieldList.i, *VariantArray.variant, *SA.SAFEARRAY

  ...
 
  While Not oMicrotech\GetIntegerProperty("Eof()")
      
      *VariantArray = oMicrotech\GetVariantProperty("ReadFieldListValues(" + Str(FieldList) + ")")
      *SA = *VariantArray\bstrVal
      
      AdrNr$ = GetVariantString(*SA\pvData\Value[0])
      
      If Not FindMapElement(*Ini\AddressMap(), AdrNr$)
        AddMapElement(*Ini\AddressMap(), AdrNr$)
        *Ini\AddressMap()\Name$ = AdrNr$ + " " + GetVariantString(*SA\pvData\Value[1])
        ;Debug *Ini\AddressMap()\Name$
      EndIf
      
      FreeStructureVariant(*VariantArray)
      
      oMicrotech\Invoke("Next()")
    Wend

If I comment FreeStructureVariant(*VariantArray) the program works without problems.

If I debug into FreeStructureVariant() and if I go with the cursor over *Value I can see the structure.
The IMA happens at FreeStructure(*Value).

Any idea?

Btw. I use COMatePlus to do the Microtech stuff.

[mk-soft]

The function "FreeStructureVariant" is only available for the function "FreeStructureVariant" when using #PB_Any

So a "VariantClear_(*Value)" is sufficient. Even if the Variant is a pointer to a SafeArray

MSDN: https://docs.microsoft.com/en-us/window ... riantclear

[infratec]

Thanks for the clarification.

[mk-soft]

Update v2.10
- Bugfix release objects

Found another bug and optimised the release of the objects

[mk-soft]

AddOn SmartTags Update v2.06
- Added SmartTags as object method
- Set and get SmartTags explizite as text

* Modul SmartTags

The SmartTags can now be used as object methods.
As you often forget to release the object again (Set Obj = Nothing), these are automatically released at the end.
In addition, SmartTags can now be explicitly read or written as text (type conversion).

Example 18

Code: Select all

;-TOP

; Comment   : Modul ActiveScript Example 18
; Version   : v2.05.1

; 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.s , value.d

vbs = ~"dim var1, var2, var3, datum" + #LF$
vbs + ~"Set var1 = SmartTags('datum')" + #LF$
vbs + ~"Set var2 = SmartTags('value')" + #LF$
vbs + ~"Set var3 = SmartTags('time')" + #LF$
vbs + ~"var1.value = var1.value + 1.0" + #LF$
vbs + ~"datum = var1.text" + #LF$
vbs + ~"msgbox datum & vbNewLine & var2.value" + #LF$
vbs + ~"Set var1 = Nothing" + #LF$
vbs + ~"Set var2 = Nothing" + #LF$
vbs + ~"var3.text = time()" + #LF$
;vbs + ~"smarttags.text(\"time\") = time()" + #LF$
;vbs + ~"Set var3 = Nothing" + #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 = GetVariantString(SmartTags("time"))
  If SmartTags("time")\vt = #VT_BSTR
    time = PeekS(SmartTags("time")\bstrVal)
  EndIf
  Debug "Time = " + time
  Debug "Value = " + GetVariantDouble(SmartTags("value"))
EndIf

[mk-soft]

Update v2.11
- New and FreeActiveScript revised to release all resources.

ActiveScript.Close() is now used with FreeActiveScript. This automatically releases the objects created in the VBScript.
This should eliminate memory leaks.

Note. ActiveScript.Close() also reduces the RefCounter of the ActiveScript object. The RefCounter is therefore increased in NewActiveScript.