MSScriptControl - Does it work with PB4?

[bingo]

for testing and learning in pb4 ...

Code: Select all

Procedure.l Ansi2Uni(ansi.s) 
SHStrDup_(@ansi,@memziel)
ProcedureReturn memziel
EndProcedure

Procedure.s Uni2Ansi(*Unicode.l) 
size.l = WideCharToMultiByte_(#CP_ACP, 0, *Unicode, -1, #Null, #Null, #Null, #Null) 
ansi.s=Space(size) 
WideCharToMultiByte_(#CP_ACP, 0, *Unicode, -1, @ansi, size, #Null, #Null) 
ProcedureReturn ansi  
EndProcedure

x.VARIANT 
x\vt = #VT_BSTR

Interface IScriptProcedure Extends IDispatch
  get_Name(a)
  get_NumArgs(a)
  get_HasReturnValue(a)
EndInterface

Interface IScriptProcedureCollection Extends IDispatch
  get__NewEnum(a)
  get_Item(a,b,c,d,e)
  get_Count(a)
EndInterface

Interface IScriptModule Extends IDispatch
  get_Name(a)
  get_CodeObject(a)
  get_Procedures(a)
  AddCode(a)
  Eval(a,b)
  ExecuteStatement(a)
  Run(a,b,c)
EndInterface

Interface IScriptModuleCollection Extends IDispatch
  get__NewEnum(a)
  get_Item(a,b,c,d,e)
  get_Count(a)
  Add(a,b,c)
EndInterface

Interface IScriptError Extends IDispatch
  get_Number(a)
  get_Source(a)
  get_Description(a)
  get_HelpFile(a)
  get_HelpContext(a)
  get_Text(a)
  get_Line(a)
  get_Column(a)
  Clear()
EndInterface

Interface IScriptControl Extends IDispatch
  get_Language(a)
  put_Language(a)
  get_State(a)
  put_State(a)
  put_SitehWnd(a)
  get_SitehWnd(a)
  get_Timeout(a)
  put_Timeout(a)
  get_AllowUI(a)
  put_AllowUI(a)
  get_UseSafeSubset(a)
  put_UseSafeSubset(a)
  get_Modules(a)
  get_Error(a)
  get_CodeObject(a)
  get_Procedures(a)
  _AboutBox()
  AddObject(a,b,c)
  Reset()
  AddCode(a)
  Eval(a,b)
  ExecuteStatement(a)
  Run(a,b,c)
EndInterface

CoInitialize_(0)
If CoCreateInstance_(?CLSID_ScriptControl,0,1,?IID_IScriptControl,@Object.IScriptControl) = 0

object\reset() 
object\put_Language(Ansi2Uni("vbscript")) 
object\AddCode(Ansi2Uni(PeekS(?sample_vbs)))

object\Eval(Ansi2Uni("sample"),@x)
Debug uni2ansi(x\bstrVal)

object\reset() 

object\release()

Else
  MessageRequester("error", "msscriptcontrol error [msscript.ocx] !", #MB_ICONHAND) 
  End 
EndIf
CoUninitialize_()

DataSection
  CLSID_ScriptControl:
  Data.l $0e59f1d5
  Data.w $1fbe,$11d0
  Data.b $8f,$f2,$00,$a0,$d1,$00,$38,$bc
    
  IID_IScriptControl:
  Data.l $0e59f1d3
  Data.w $1fbe,$11d0
  Data.b $8f,$f2,$00,$a0,$d1,$00,$38,$bc
EndDataSection 

;sample vbs
DataSection 
sample_vbs: 
  Data.s "a=1:b=2:sample=cstr(a+b):msgbox(sample)"
  Data.b 0 
EndDataSection

[Shannara]

Bingo: Ah, I need to check that out tonight.

(rest):

Someone on the forums said that using VTables can emulate classes that can be placed in AddObject. Problem is, the compiled userlib in the linked thread works (except for missing addobject), and since the "global" script variable is inside a procedure, it is not global outside of the userlib. So you cant access the addobject from there.

However, the source provided breaks everytime you run coInit.... Thus I am assuming it has the wrong ID code in it. And every tool I found on these forums (so far) doesnt provide the correct id, or whatnot.

[X]

I believe the code below may hold the answer.

Code: Select all

Interface IPBFriendly
  SayHello()
  SayGoodbye()
  TellMyName(Name.s)
EndInterface

Structure VTPBFriendlyFunctions
  SayHello.l
  SayGoodbye.l
  TellMyName.l
EndStructure

Structure PBFriendly
  *VirtualTable.VTPBFriendlyFunctions
  Name.s
EndStructure

Procedure SayHello(*Self.PBFriendly)
  If *Self\Name > ""
    MessageRequester("Friendly", "Hello " + *Self\Name + ".")
  Else
    MessageRequester("Friendly", "Hello.  I'm afraid we haven't been introduced")
  EndIf
EndProcedure

Procedure SayGoodbye(*Self.PBFriendly)
  If *Self\Name > ""
    MessageRequester("Friendly", "Goodbye " + *Self\Name + ".")
  Else
    MessageRequester("Friendly", "Goodbye.  It's a shame we didn't get to know each other better")
  EndIf
EndProcedure

Procedure TellMyName(*Self.PBFriendly, Name.s)
  *Self\Name = Name
  MessageRequester("Friendly", "Pleased to meet you, " + Name + ", I'm Purebasic.")
EndProcedure

Global VTPBFriendly.VTPBFriendlyFunctions
VTPBFriendly\SayHello = @SayHello()
VTPBFriendly\SayGoodbye = @SayGoodbye()
VTPBFriendly\TellMyName = @TellMyName()

Global NewList Instances.PBFriendly()

Procedure.l CreateFriendly()
  ; Create a new PBFriendly within the Instances list.
  AddElement(Instances())
  
  ; Assign the Virtual table
  Instances()\VirtualTable = VTPBFriendly
  
  ; Initialise the fields
  Instances()\Name = ""
  
  ; Return a pointer (hence the @) to the new structure
  ProcedureReturn @Instances()
EndProcedure

Procedure.l Ansi2Uni(ansi.s)
  SHStrDup_(@ansi,@memziel)
  ProcedureReturn memziel
EndProcedure

Procedure.s Uni2Ansi(*Unicode.l)
  Size.l = WideCharToMultiByte_(#CP_ACP, 0, *Unicode, -1, #Null, #Null, #Null, #Null)
  ansi.s=Space(Size)
  WideCharToMultiByte_(#CP_ACP, 0, *Unicode, -1, @ansi, Size, #Null, #Null)
  ProcedureReturn ansi 
EndProcedure

x.VARIANT
x\vt = #VT_BSTR

Interface IScriptProcedure Extends IDispatch
  get_Name(a)
  get_NumArgs(a)
  get_HasReturnValue(a)
EndInterface

Interface IScriptProcedureCollection Extends IDispatch
  get__NewEnum(a)
  get_Item(a,b,c,d,e)
  get_Count(a)
EndInterface

Interface IScriptModule Extends IDispatch
  get_Name(a)
  get_CodeObject(a)
  get_Procedures(a)
  AddCode(a)
  Eval(a,b)
  ExecuteStatement(a)
  Run(a,b,c)
EndInterface

Interface IScriptModuleCollection Extends IDispatch
  get__NewEnum(a)
  get_Item(a,b,c,d,e)
  get_Count(a)
  Add(a,b,c)
EndInterface

Interface IScriptError Extends IDispatch
  get_Number(a)
  get_Source(a)
  get_Description(a)
  get_HelpFile(a)
  get_HelpContext(a)
  get_Text(a)
  get_Line(a)
  get_Column(a)
  Clear()
EndInterface

Interface IScriptControl Extends IDispatch
  get_Language(a)
  put_Language(a)
  get_State(a)
  put_State(a)
  put_SitehWnd(a)
  get_SitehWnd(a)
  get_Timeout(a)
  put_Timeout(a)
  get_AllowUI(a)
  put_AllowUI(a)
  get_UseSafeSubset(a)
  put_UseSafeSubset(a)
  get_Modules(a)
  get_Error(a)
  get_CodeObject(a)
  get_Procedures(a)
  _AboutBox()
  AddObject(a,b,c)
  Reset()
  AddCode(a)
  Eval(a,b)
  ExecuteStatement(a)
  Run(a,b,c)
EndInterface

Procedure myBox()
  MessageRequester("This Works", "This Works!", #PB_MessageRequester_Ok)
EndProcedure

CoInitialize_(0)
If CoCreateInstance_(?CLSID_ScriptControl,0,1,?IID_IScriptControl,@Object.IScriptControl) = 0
  
  Object\Reset()
  Object\put_Language(Ansi2Uni("vbscript"))
  
  
  Simon.IPBFriendly = CreateFriendly()
  ;Simon\SayHello()
  Object\AddObject(Ansi2Uni("myBox"), @Simon.IPBFriendly, 0)
   
  Object\AddCode(Ansi2Uni(PeekS(?sample_vbs)))
  
  Object\Eval(Ansi2Uni("sample"),@x)
  Debug Uni2Ansi(x\bstrVal)
  
  Object\Reset()
  
  Object\release()
  
Else
  MessageRequester("error", "msscriptcontrol error [msscript.ocx] !", #MB_ICONHAND)
  End
EndIf
CoUninitialize_()

DataSection
CLSID_ScriptControl:
Data.l $0E59F1D5
Data.w $1FBE,$11D0
Data.b $8F,$F2,$00,$A0,$D1,$00,$38,$BC
   
IID_IScriptControl:
Data.l $0E59F1D3
Data.w $1FBE,$11D0
Data.b $8F,$F2,$00,$A0,$D1,$00,$38,$BC
EndDataSection

;sample vbs
DataSection
sample_vbs:
Data.s "a=1:b=2:sample=cstr(a+b):msgbox(sample)"
Data.b 0
EndDataSection

[Rings]

@X: i got an memory exception error at:

Object\AddObject(Ansi2Uni("myBox"), @Simon.IPBFriendly, 0)

any hints ?

using w2k with PB4.0x

[X]

May try replace

Code: Select all

@Simon.IPBFriendly

with

Code: Select all

Simon

[netmaestro]

That helps, but now I get an IMA on line 37.

BTW, Bingo's code works fine here.

[X]

I think the problem was AddObject member? Here I try to help on that. Problem with my code above, if "class" have more then 1 function, all are called when pass class to AddObject. I do not know how to fix.

[ricardo]

I believe the code below may hold the answer.

This looks great but i cant compile it (PB 4)

Im very interested on some way to make this work.