Solved

Adding VBScript and JavaScript to Delphi 7  (Active Script)

Posted on 2004-09-23
35
5,976 Views
Last Modified: 2012-06-21
Greetings,

I have a client program, and I want the ability for users to add either VBScript or JavaScript custom scripts to it.

Basically I want the ability to start them off with a scripts.txt file that lays out what events are supported.

Also, I need to add a function in the scripts that allows them to output to the chat box.

Sub Event_UserTalk(Username, Flags, Message, Ping)
  AddQ "/w "&Username&" Hi!"
End Sub

Currently, I am playing with psvActiveScript, but not sure how to use it.

I need example code on how to get data from an event and trigger a sub in the script, and how to have the script send data back to my application.  Please don't just give links.  Thanks.
0
Comment
Question by:werehamster-
  • 19
  • 6
  • 6
  • +2
35 Comments
 
LVL 9

Expert Comment

by:ginsonic
ID: 12140081
Add a TWebBrowser and run it from there.
0
 

Author Comment

by:werehamster-
ID: 12140224
ginsonic,
  -  Don't take this the wrong way, but I don't see how that comment helps me at all.  Could you elaborate or provide some sample code?  I do appreciate it though.

everyone else,
  -  Basically what I am looking for is something that I can do...

procedure DisplayString(S:String);
begin
  Form1.Memo1.Lines.Add(S);
end;

function Blah : string;
begin
  result := 'Blah';
end;


In a script...

Sub Event_UserTalk(Username, Flags, Message, Ping)
  DisplayString "Hi "&Username&" Hi!"
  Call DisplayString("My favorite word is "&Blah&"!")
End Sub
0
 
LVL 3

Expert Comment

by:entrapnet
ID: 12140329
p/s: if you are using windows 98 and below, you should go and download windows script host in www.microsoft.com

(base on delphi 7)
1) click component/import active-x component/Microsoft Script control 1.0/install.
2) put MSScriptControl_TLB under your uses section. Put in the function below to your program

function  SMT_MCCScript(FunctionName : String; FunctionParam : String) : integer;
var
  ScriptControl  : TScriptControl;
  ScriptCode     : TStringList;
  ScriptText     : String;
  ScriptFilename : TextFile;
  ProcessFile    : Boolean;
  varScriptControl : Variant;
  LoadedScript : TStringList;
begin
  Result := TargetUnit;

  ScriptControl := TScriptControl.create(application);
  ScriptControl.Language := 'VBScript';
  ScriptControl.Reset;
  ScriptCode := TStringList.Create;

  Scriptcode.Clear;
  ScriptCode := ExportToStringList(TargetUnit);

  AssignFile(ScriptFilename,extractfilepath(application.ExeName) + localsetting + '.mcc');
  {$I-}
  ProcessFile := false;

  if fileexists(extractfilepath(application.ExeName) + 'kenny.mcc') then
  begin
    FileMode := 0;
    reset(ScriptFileName);
    ProcessFile := true;
  end
  else
  begin
     showmessage('need keny.mcc included with your exe file');
    application.terminate;
  end;

  ' to load the vb script into the system
  LoadedScript := TStringList.create;
  LoadedScript.Clear;
  if ProcessFile then
  begin
    while not eof(ScriptFilename) do
    begin
      readln(ScriptFilename, ScriptText);
      LoadedScript.add(ScriptText);
    end;
    close(ScriptFilename);
  end;
  {$I+}  

  ScriptCode.AddStrings(LoadedScript);
  ScriptCode.SaveToFile('c:\mcc_script_debug.txt');
  ScriptControl.AddCode(ScriptCode.Text);

  varScriptControl := ScriptControl.ControlInterface;
  try
    varScriptControl.Run(FunctionName);

  except

    'if the function is not exist... create a template for it

    if ScriptCode.IndexOf('    function ' + functionname) = -1 then
    begin
      AssignFile(ScriptFilename,extractfilepath(application.ExeName) + localsetting + '.mcc');
      {$I-}
      append(ScriptFilename);
      writeln(ScriptFilename,'');
      writeln(ScriptFilename,'    function ' + functionname);
      writeln(ScriptFilename,'    end function');
      writeln(ScriptFilename,'');
      flush(ScriptFilename);
      close(ScriptFilename);
      {$I+}
    end;
  end;

 
end;

3) create kenny.mcc into the same folder where you exe located (usually the same place with your source code)
4) copy this command into the kenny.mcc file

function test
  msgbox("hello world!")
end fucntion

5) save kenny.mcc file
6) put a button into your delphi program
7) under your button command... type this

SMT_MCCScript('test','');

8) please take note... this is modified version from the original which I used over my project. Please do drop me an email so that I can update any mistake along the way.
0
 
LVL 3

Expert Comment

by:entrapnet
ID: 12140331
oh yeah... my email is kennyk@teleplan-my.com
0
 

Author Comment

by:werehamster-
ID: 12140421
I already have a copy of MSScriptControl_TLB from another component I added.

This just looks like it reads and edits a file and adds the function if it does not exist.  How do I run the script and stuff?  Is it possible for you to make a compilable example of this.  I am still a little confused.

Thanks.
0
 
LVL 3

Expert Comment

by:entrapnet
ID: 12140440
anyway... my msn is kennyk@teleplan-my.com

It will execute it too.... trust me

varScriptControl.Run(FunctionName); <--- this is where the command it will execute the function... if it fail, it will create the function template in kenny.mcc


0
 

Author Comment

by:werehamster-
ID: 12140443
I just saw how you loaded it.  should have read more carefully, but still kinda confused.  :)
0
 
LVL 3

Expert Comment

by:entrapnet
ID: 12140450
what it does is very simpe

1) load the script
2) run the script
3) if the script fail, create a template for the programmer to create
0
 

Author Comment

by:werehamster-
ID: 12140457
What is TargetUnit supposed to be?
0
 
LVL 3

Expert Comment

by:entrapnet
ID: 12140469
delete the targetunit...

it was from the original software.
0
 

Author Comment

by:werehamster-
ID: 12140475
How do I add functions for the script to use, and have the script pass back information?  I'm all confused.  I can't even get it to run.
0
 
LVL 3

Assisted Solution

by:entrapnet
entrapnet earned 50 total points
ID: 12140517
my mistake...

this is the whole coding

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls,MSScriptControl_TLB ;

type
  TForm1 = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
    function SMT_MCCScript(FunctionName : String; FunctionParam : String) : integer;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}
function  tform1.SMT_MCCScript(FunctionName : String; FunctionParam : String) : integer;
var
  ScriptControl  : TScriptControl;
  ScriptCode     : TStringList;
  ScriptText     : String;
  ScriptFilename : TextFile;
  ProcessFile    : Boolean;
  varScriptControl : Variant;
  LoadedScript : TStringList;
begin

  ScriptControl := TScriptControl.create(application);
  ScriptControl.Language := 'VBScript';
  ScriptControl.Reset;
  ScriptCode := TStringList.Create;

  Scriptcode.Clear;

  AssignFile(ScriptFilename,extractfilepath(application.ExeName) + 'kenny.mcc');
  {$I-}
  ProcessFile := false;

  if fileexists(extractfilepath(application.ExeName) + 'kenny.mcc') then
  begin
    FileMode := 0;
    reset(ScriptFileName);
    ProcessFile := true;
  end
  else
  begin
     showmessage('need keny.mcc included with your exe file');
    application.terminate;
  end;

  // to load the vb script into the system
  LoadedScript := TStringList.create;
  LoadedScript.Clear;
  if ProcessFile then
  begin
    while not eof(ScriptFilename) do
    begin
      readln(ScriptFilename, ScriptText);
      LoadedScript.add(ScriptText);
    end;
    closefile(ScriptFilename);
  end;
  {$I+}

  ScriptCode.AddStrings(LoadedScript);
  ScriptCode.SaveToFile('c:\mcc_script_debug.txt');
  ScriptControl.AddCode(ScriptCode.Text);

  varScriptControl := ScriptControl.ControlInterface;
  try
    varScriptControl.Run(FunctionName);

  except

    //if the function is not exist... create a template for it

    if ScriptCode.IndexOf('    function ' + functionname) = -1 then
    begin
      AssignFile(ScriptFilename,extractfilepath(application.ExeName) + 'kenny.mcc');
      {$I-}
      append(ScriptFilename);
      writeln(ScriptFilename,'');
      writeln(ScriptFilename,'    function ' + functionname);
      writeln(ScriptFilename,'    end function');
      writeln(ScriptFilename,'');
      flush(ScriptFilename);
      closefile(ScriptFilename);
      {$I+}
    end;
  end;

 
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  SMT_MCCScript('test','');
end;

end.
0
 
LVL 2

Expert Comment

by:php4delphi
ID: 12141045
If you are using psvActiveScript the solutions depends from your Delphi version. The most easy will be implementation for Delphi 7
I made a generic example for, it should works for Delphi 5-7

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  psvActiveScript, StdCtrls, ActiveX;

type
  TfrmScriptDemo = class(TForm)
    Memo1: TMemo;
    Button1: TButton;
    psvActiveScriptWindow: TpsvActiveScriptWindow;
    Memo2: TMemo;
    procedure Button1Click(Sender: TObject);
    procedure psvActiveScriptWindowError(Sender: TObject; Line,
      Pos: Integer; ASrc, ADescription: String);
  private
    { Private declarations }
  public
    { Public declarations }
    Username, Flags, _Message, Ping : string;
    end;

var
  frmScriptDemo: TfrmScriptDemo;

implementation

{$R *.DFM}

type
  TDispatchProc = procedure of object;
  TListObj = class
   Proc : TDispatchProc;
  end;

  TAdditionalScriptProcedures = class(TInterfacedObject, IDispatch)
  private
    FunctionList : TStringList;
    FRetValue : variant;
    FParams : PDispParams;
    function GetInputArg(AIndex: integer): variant;
  protected
    procedure DisplayString;
    procedure Blah;
  public
      { IDispatch }
    function GetIDsOfNames(const IID: TGUID; Names: Pointer;
      NameCount: Integer; LocaleID: Integer; DispIDs: Pointer): HRESULT;
      virtual; stdcall;
    function GetTypeInfo(Index: Integer; LocaleID: Integer;
      out TypeInfo): HRESULT; stdcall;
    function GetTypeInfoCount(out Count: Integer): HRESULT; stdcall;
    function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
      Flags: Word; var Params; VarResult: Pointer; ExcepInfo: Pointer;
      ArgErr: Pointer): HRESULT; virtual; stdcall;

    constructor Create;
    Destructor  Destroy; override;
  end;

{ TAdditionalScriptProcedures }

procedure TAdditionalScriptProcedures.Blah;
begin
 FRetValue := 'Blah';
end;

constructor TAdditionalScriptProcedures.Create;
var
 p : TListObj;
begin
  inherited;
  FunctionList := TStringList.Create;

  //Add functions
  P := TListObj.Create;
  P.Proc := DisplayString;
  FunctionList.AddObject('DisplayString', P);

  P := TListObj.Create;
  P.Proc := Blah;
  FunctionList.AddObject('Blah', P);
end;

destructor TAdditionalScriptProcedures.Destroy;
var
 cnt : integer;
begin
  for cnt := 0 to FunctionList.Count - 1 do
   FunctionList.Objects[cnt].Free;
  FunctionList.Free;
  inherited;
end;

procedure TAdditionalScriptProcedures.DisplayString;
var
 S : string;
begin
 S := GetInputArg(0);
 frmScriptDemo.Memo1.Lines.Add(S);
end;

function TAdditionalScriptProcedures.GetIDsOfNames(const IID: TGUID;
  Names: Pointer; NameCount, LocaleID: Integer; DispIDs: Pointer): HRESULT;
type
  TDispIDsArray = array[0..0] of TDISPID;
  PDispIDsArray = ^TDispIDsArray;
var
  IDs: PDispIDsArray absolute DispIDs;
  i: integer;
  Name: WideString;
begin
  if NameCount > 1 then Result := DISP_E_UNKNOWNNAME
  else
    if NameCount < 1 then Result := E_INVALIDARG
    else Result := S_OK;
  for i := 0 to NameCount - 1 do
    IDs[i] := DISPID_UNKNOWN;
  if NameCount = 1 then
    begin
      Name := PWideChar(Names^);
      IDs[0] := FunctionList.IndexOf(Name);
       if IDs[0] = -1 then
        Result := DISP_E_UNKNOWNNAME;
    end;
end;

function TAdditionalScriptProcedures.GetInputArg(AIndex: integer): variant;
begin
  if (AIndex < 0) or (AIndex >= FParams^.cArgs) then
        TList.Error('Index Error', AIndex);
  Result := Variant(FParams^.rgvarg^[FParams^.cArgs - 1 - AIndex])
end;

function TAdditionalScriptProcedures.GetTypeInfo(Index, LocaleID: Integer;
  out TypeInfo): HRESULT;
begin
  Result := E_NOTIMPL;
end;

function TAdditionalScriptProcedures.GetTypeInfoCount(
  out Count: Integer): HRESULT;
begin
  Result := E_NOTIMPL;
end;

function TAdditionalScriptProcedures.Invoke(DispID: Integer;
  const IID: TGUID; LocaleID: Integer; Flags: Word; var Params; VarResult,
  ExcepInfo, ArgErr: Pointer): HRESULT;

var
 P : TDispatchProc;
begin
  if not VarIsEmpty(FRetValue) then
   VarClear(FRetValue);

  Result := DISP_E_MEMBERNOTFOUND;
  if DispID >= FunctionList.Count then
   Exit;
  try
  FParams := @Params;
  if DispID <> -1 then
    if (Flags = DISPATCH_METHOD) or (Flags and not DISPATCH_METHOD = DISPATCH_PROPERTYGET) then
      begin
        p := TListObj(FunctionList.Objects[DispID]).Proc;
        if Assigned(P) then
         P;
      end;

  if not VarIsEmpty(FRetValue) then
   POleVariant(VarResult)^ := FRetValue;
  Result := S_OK;
  except
    on E : Exception do
     begin
       Result := DISP_E_EXCEPTION;
     end;
  end;
end;

procedure TfrmScriptDemo.Button1Click(Sender: TObject);
var
 ScriptText : string;
 MyProcedures : TAdditionalScriptProcedures;
begin
  MyProcedures := TAdditionalScriptProcedures.Create;
  psvActiveScriptWindow.AddNamedItem('Basic', Myprocedures);
   UserName := 'ginsonic';
   Flags := '0';
   _Message := 'Hello';
   Ping := 'Ping';


  //just for demo
  Memo2.Clear;
  Memo2.Lines.Add('Event_UserTalk "' + UserName +
  '", "' + Flags + '", "' + _Message + '", "' + Ping + '"');
  Memo2.Lines.Add('Sub Event_UserTalk(Username, Flags, Message, Ping)');
  Memo2.Lines.Add('DisplayString "Hi "&Username&" Hi!"');
  Memo2.Lines.Add('Call DisplayString("My favorite word is "&Blah&"!")');
  Memo2.Lines.Add('End Sub');


  //event occurs, execute script
  ScriptText := Memo2.Text;
  psvActiveScriptWindow.Execute(ScriptText);
end;

procedure TfrmScriptDemo.psvActiveScriptWindowError(Sender: TObject; Line,
  Pos: Integer; ASrc, ADescription: String);
begin
  ShowMessage('Line: ' + IntToStr(Line +1) + ' ' + ADescription);
end;

end.


psvActiveScript works without windows script host and allows real integration with your Delphi application.
0
 

Author Comment

by:werehamster-
ID: 12141316
php4delphi -- Yeah, I was messing with it a bit, but could not understand it all too well.  Found some other source that did the same thing that messes with a lot of interface stuff that I have no clue how to do as well using VBA or something.

I assume you forgot to add uses Variants as I coudn't compile.

Also, I am not getting it to add anything to memo1 as I think you intended.
0
 

Author Comment

by:werehamster-
ID: 12141335
Would this be something that would have to be synchronized normally?
0
 
LVL 2

Expert Comment

by:SChertkov
ID: 12141348
More simple way to use TAutoIntfObject + Type library instead of own IDispatch implementation.
You create type library in application and add something like this

IMyInterface = interface(IDispatch)
['{9275B45A-2187-4793-B8CF-16CF8F2A6708}']
  procedure DisplayString(const S:WideString);
  function Blah : WideString;
end;

In you code

TMyObject = class(TAutoIntfObject, IMyInterface)
  procedure DisplayString(const S:WideString);
  function Blah : WideString;
end;

....
  MyInterface := TMyObject.Create(IMyInterface, ComServer.TypeLib);
0
 

Author Comment

by:werehamster-
ID: 12141392
Schertkov, could you possibly give me a sample?  I'm not good with this stuff at all, and the only way I learn is by example.  Soon as I see ['{...}'] my head starts to hurt.  :)

I dunno, but it looks like he had to do it that way because of having to call GetInputArg(0).

If I could get one solid working example, I'd be all peachy.  :)
0
How to run any project with ease

Manage projects of all sizes how you want. Great for personal to-do lists, project milestones, team priorities and launch plans.
- Combine task lists, docs, spreadsheets, and chat in one
- View and edit from mobile/offline
- Cut down on emails

 

Author Comment

by:werehamster-
ID: 12141404
Ok, basically I would just copy ActiveScriptObj apparently.  Haven't tested it yet though.
0
 

Author Comment

by:werehamster-
ID: 12141421
I do have a major question to ask here though.  If I run multiple copies of the applications, are the messages going to get mixed up between them all?
0
 
LVL 2

Expert Comment

by:SChertkov
ID: 12141528
I think you can modify php4delphi example.
In delphi environment choose New | Other... ActiveX Type Library

In type library editor click "New Interface" and create methods DisplayString
and Balah. Save TypeLib and use generated unit YouTypeLib_TLB and
units ComObj, ComServ in you test form.

Next simple inherit TIntfAutoObject with you interface and replace
string
 MyProcedures := TAdditionalScriptProcedures.Create;
on
 MyInterface := TMyObject.Create(IMyInterface, ComServer.TypeLib);
in previos example.
0
 

Author Comment

by:werehamster-
ID: 12141535
This is what I came up with.  How would I change it to do the...

IMyInterface = interface(IDispatch)
['{9275B45A-2187-4793-B8CF-16CF8F2A6708}']''

... thing?



unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, psvActiveScript, comobj;

type
  TForm1 = class(TForm)
    btnExecute: TButton;
    pw: TpsvActiveScriptWindow;
    Memo1: TMemo;
    Memo2: TMemo;
    procedure btnExecuteClick(Sender: TObject);
    procedure pwError(Sender: TObject; Line, Pos: Integer; ASrc,
      ADescription: String);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

type
  TActiveBlahInfo = class(TInterfacedObject, IDispatch)
  protected
    function GetTypeInfoCount(out Count: Integer): HResult; stdcall;
    function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall;
    function GetIDsOfNames(const IID: TGUID; Names: Pointer;
      NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall;
    function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
      Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall;
  end;


var
  Form1: TForm1;

implementation

uses
  ActiveScriptObj,  ActiveX;

{$R *.DFM}

procedure TForm1.btnExecuteClick(Sender: TObject);
var
 W,W2 : IDispatch;
 O : TActiveAppInfo;
 O2 : TActiveBlahInfo;
begin
   O := TActiveAppInfo.Create;
   W := O;

   O2 := TActiveBlahInfo.Create;
   W2 := O2;

   pw.AddNamedItem('App', W);
   pw.AddNamedItem('Blah', W2);

   pw.execute(Memo1.text);
end;


procedure TForm1.pwError(Sender: TObject; Line, Pos: Integer; ASrc,
  ADescription: String);
begin
  Showmessage(ADescription + ': ' + ASrc);

end;

const
  DISPID_ADDQ  = 3;
  DISPID_BLAH = 4;

function TActiveBlahInfo.GetIDsOfNames(const IID: TGUID; Names: Pointer; NameCount,
  LocaleID: Integer; DispIDs: Pointer): HResult;
type
  TDispIDsArray = array[0..0] of TDISPID;
  PDispIDsArray = ^TDispIDsArray;
var
  IDs: PDispIDsArray absolute DispIDs;
  i: integer;
  Name: WideString;
begin
  if NameCount > 1 then Result := DISP_E_UNKNOWNNAME
  else
    if NameCount < 1 then Result := E_INVALIDARG
    else Result := S_OK;
  for i := 0 to NameCount - 1 do
    IDs[i] := DISPID_UNKNOWN;
  if NameCount = 1 then
    begin
      Name := PWideChar(Names^);
      if UpperCase(Name) = 'ADDQ' then IDs[0] := DISPID_ADDQ else
      if UpperCase(Name) = 'BLAH' then IDs[0] := DISPID_BLAH else
       Result := DISP_E_UNKNOWNNAME;
    end;
end;

function TActiveBlahInfo.GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult;
begin
  Pointer(TypeInfo) := nil;
  Result := E_NOTIMPL;
end;

function TActiveBlahInfo.GetTypeInfoCount(out Count: Integer): HResult;
begin
  Count := 0;
  Result := S_OK;
end;

function TActiveBlahInfo.Invoke(DispID: Integer; const IID: TGUID;
  LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo,
  ArgErr: Pointer): HResult;

type
  PVariantArray = ^TVariantArray;
  TVariantArray = array[0..65535] of Variant;
  PIntegerArray = ^TIntegerArray;
  TIntegerArray = array[0..65535] of Integer;
var
  Parms: PDispParams;
  FRetValue : Variant;
begin
  if (DispID = DISPID_BLAH) then
    begin
      if VarResult = nil then
        VarResult := @FRetValue;
      POleVariant(VarResult)^ := 'Blah';
      Result := S_OK;
    end
  else
  if (DispID = DISPID_ADDQ) then
    begin
      Parms := @Params;
      Form1.Memo2.Lines.Add(PVariantArray(Parms.rgvarg)^[0]);
      Result := S_OK;
    end
  else

Result := DISP_E_MEMBERNOTFOUND;
end;


end.
0
 
LVL 2

Expert Comment

by:php4delphi
ID: 12141543
OK, lets make this more clear.

First, you need a special class to implement your idea.
Copy CustomProcedures.pas unit to your application folder and leave it as is.
It implements the basic custom class for all future manipulations.

unit CustomProcedures;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  psvActiveScript, StdCtrls, ActiveX, Variants;

type
  TDispatchProc = procedure of object;
  TListObj = class
   Proc : TDispatchProc;
  end;

  TCustomScriptProcedures = class(TInterfacedObject, IDispatch)
  protected
    FunctionList : TStringList;
    FRetValue : variant;
    FParams : PDispParams;
    function GetInputArg(AIndex: integer): variant;
    function GetIDsOfNames(const IID: TGUID; Names: Pointer;
      NameCount: Integer; LocaleID: Integer; DispIDs: Pointer): HRESULT;
      virtual; stdcall;
    function GetTypeInfo(Index: Integer; LocaleID: Integer;
      out TypeInfo): HRESULT; stdcall;
    function GetTypeInfoCount(out Count: Integer): HRESULT; stdcall;
    function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
      Flags: Word; var Params; VarResult: Pointer; ExcepInfo: Pointer;
      ArgErr: Pointer): HRESULT; virtual; stdcall;
  public
    constructor Create; virtual;
    Destructor  Destroy; override;
  end;

implementation

{ TCustomScriptProcedures }

constructor TCustomScriptProcedures.Create;
begin
  inherited;
  FunctionList := TStringList.Create;
end;

destructor TCustomScriptProcedures.Destroy;
var
 cnt : integer;
begin
  for cnt := 0 to FunctionList.Count - 1 do
   FunctionList.Objects[cnt].Free;
  FunctionList.Free;
  inherited;
end;

function TCustomScriptProcedures.GetIDsOfNames(const IID: TGUID;
  Names: Pointer; NameCount, LocaleID: Integer; DispIDs: Pointer): HRESULT;
type
  TDispIDsArray = array[0..0] of TDISPID;
  PDispIDsArray = ^TDispIDsArray;
var
  IDs: PDispIDsArray absolute DispIDs;
  i: integer;
  Name: WideString;
begin
  if NameCount > 1 then Result := DISP_E_UNKNOWNNAME
  else
    if NameCount < 1 then Result := E_INVALIDARG
    else Result := S_OK;
  for i := 0 to NameCount - 1 do
    IDs[i] := DISPID_UNKNOWN;
  if NameCount = 1 then
    begin
      Name := PWideChar(Names^);
      IDs[0] := FunctionList.IndexOf(Name);
       if IDs[0] = -1 then
        Result := DISP_E_UNKNOWNNAME;
    end;
end;

function TCustomScriptProcedures.GetInputArg(AIndex: integer): variant;
begin
  if (AIndex < 0) or (AIndex >= FParams^.cArgs) then
        TList.Error('Index Error', AIndex);
  Result := Variant(FParams^.rgvarg^[FParams^.cArgs - 1 - AIndex])
end;

function TCustomScriptProcedures.GetTypeInfo(Index, LocaleID: Integer;
  out TypeInfo): HRESULT;
begin
  Result := E_NOTIMPL;
end;

function TCustomScriptProcedures.GetTypeInfoCount(
  out Count: Integer): HRESULT;
begin
  Result := E_NOTIMPL;
end;

function TCustomScriptProcedures.Invoke(DispID: Integer; const IID: TGUID;
  LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo,
  ArgErr: Pointer): HRESULT;
var
 P : TDispatchProc;
begin
  if not VarIsEmpty(FRetValue) then
   VarClear(FRetValue);

  Result := DISP_E_MEMBERNOTFOUND;
  if DispID >= FunctionList.Count then
   Exit;
  try
  FParams := @Params;
  if DispID <> -1 then
    if (Flags = DISPATCH_METHOD) or (Flags and not DISPATCH_METHOD = DISPATCH_PROPERTYGET) then
      begin
        p := TListObj(FunctionList.Objects[DispID]).Proc;
        if Assigned(P) then
         P;
      end;

  if not VarIsEmpty(FRetValue) then
   POleVariant(VarResult)^ := FRetValue;
  Result := S_OK;
  except
    on E : Exception do
     begin
       Result := DISP_E_EXCEPTION;
     end;
  end;
end;

end.




Now you have to create your own class inherited from TCustomscriptProcedures to implement the functions you want to add.

unit MyProcedures;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  psvActiveScript, StdCtrls, ActiveX, Variants, CustomProcedures;

type
  TMyProcedures = class(TCustomScriptProcedures)
  protected
    procedure DisplayString;
    procedure Blah;
  public
    constructor Create; override;
  end;  


implementation

uses
  Unit1;

{ TMyProcedures }

procedure TMyProcedures.Blah;
begin
 //if you implement a function always assign result to FRetValue
 FRetValue := 'Blah';
end;

constructor TMyProcedures.Create;
var
 p : TListObj;
begin
  inherited;
  //Add functions
  P := TListObj.Create;
  P.Proc := DisplayString;
  FunctionList.AddObject('DisplayString', P);

  P := TListObj.Create;
  P.Proc := Blah;
  FunctionList.AddObject('Blah', P);
end;

procedure TMyProcedures.DisplayString;
var
 S : string;
begin
//retrieve argument
 S := GetInputArg(0);
 Form1.Memo1.Lines.Add(S);
end;

end.


You can change this class as you want to achieve your goal.
And now you can add it to the application

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, psvActiveScript, CustomProcedures, MyProcedures;

type
  TForm1 = class(TForm)
    psvActiveScriptWindow: TpsvActiveScriptWindow;
    Memo1: TMemo;
    Memo2: TMemo;
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
    Username, Flags, _Message, Ping : string;
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
var
 ScriptText : string;
 MyProcedures : TMyProcedures;
begin
  MyProcedures := TMyProcedures.Create;
  psvActiveScriptWindow.AddNamedItem('Basic', Myprocedures);
   UserName := 'ginsonic';
   Flags := '0';
   _Message := 'Hello';
   Ping := 'Ping';


  //just for demo
  Memo2.Clear;
  Memo2.Lines.Add('Event_UserTalk "' + UserName +
  '", "' + Flags + '", "' + _Message + '", "' + Ping + '"');
  Memo2.Lines.Add('Sub Event_UserTalk(Username, Flags, Message, Ping)');
  Memo2.Lines.Add('Basic.DisplayString "Hi "&Username&" Hi!"');
  Memo2.Lines.Add('Call Basic.DisplayString("My favorite word is "&Basic.Blah&"!")');
  Memo2.Lines.Add('End Sub');

  //event occurs, execute script
  ScriptText := Memo2.Text;
  psvActiveScriptWindow.Execute(ScriptText);
end;

end.


If you want to use your function names directly, e.g. DisplayString, instead of Basic.DisplayString
change the following code in psvActiveScript.pas:

  for I := 0 to FGlobalObjects.NamedItemCount - 1 do
    FEngine.AddNamedItem(PWideChar(WideString(FGlobalObjects.NamedItemName[I])), SCRIPTITEM_ISVISIBLE);


to:

  for I := 1 to FGlobalObjects.NamedItemCount - 1 do
   begin
    if SameText(FGlobalObjects.NamedItemName[I], 'Basic') then
    FEngine.AddNamedItem(PWideChar(WideString(FGlobalObjects.NamedItemName[I])), SCRIPTITEM_ISVISIBLE  or SCRIPTITEM_GLOBALMEMBERS )
     else
       FEngine.AddNamedItem(PWideChar(WideString(FGlobalObjects.NamedItemName[I])), SCRIPTITEM_ISVISIBLE);
   end;


If you run multiple copies of the application each application will displays own messages.
0
 
LVL 2

Expert Comment

by:SChertkov
ID: 12141577
TActiveBlahInfo is not necessary because delphi ComObj
contains standard IDispatch implementation in TAutoObject and TAutoIntfObject
0
 

Author Comment

by:werehamster-
ID: 12141578
Wow, this helps a lot.
0
 
LVL 2

Expert Comment

by:php4delphi
ID: 12141644
Anyway, I would prefer not to use automation, if you are not planning to create COM-server. Is it really nessesary to add type library to you application ?

I can propose also a completely generic solution that gives a possibility to
automate any object or component using psvActiveScript.

unit psvObjAuto;

interface
 uses
  Windows, SysUtils, Classes, ActiveX, TypInfo, Consts, Controls, Graphics,
  Dialogs, Forms, Variants, RTLConsts;


type

  TDispatchProc = procedure of object;

  TpsvObjectInfo = class
   public
     ParamCount : integer;
     GetProc : TDispatchProc;
     SetProc : TDispatchProc;
   end;


  TpsvObjectDispatch = class(TInterfacedObject, IDispatch)
  private
    FInstance: TObject;
    FOwned: Boolean;
    FObjectInfo : TStringList;
    FRetValue : variant;
    FParams : PDispParams;
    procedure ObjectClassNameProc;
    procedure ObjectClassnameIsProc;
  protected
    function GetInputArg(AIndex:integer):variant;
    function GetInputArgAsString(AIndex:integer):string;
    function GetInputArgAsInteger(AIndex:integer):integer;
    function GetInputArgAsBoolean(AIndex:integer):boolean;
    function GetInputArgAsFloat(AIndex:integer):double;
    function GetInputArgAsDateTime(AIndex:integer):TDateTime;
    procedure ReturnOutputArg(AValue:variant);
    procedure RegisterMethod(AName : string; AParamCount : integer; AMethodProc : TDispatchProc);
    procedure RegisterProperty(AName : string; AGet : TDispatchProc; ASet : TDispatchProc);
  public
    { IDispatch }
    function GetIDsOfNames(const IID: TGUID; Names: Pointer;
      NameCount: Integer; LocaleID: Integer; DispIDs: Pointer): HRESULT;
      virtual; stdcall;
    function GetTypeInfo(Index: Integer; LocaleID: Integer;
      out TypeInfo): HRESULT; stdcall;
    function GetTypeInfoCount(out Count: Integer): HRESULT; stdcall;
    function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
      Flags: Word; var Params; VarResult: Pointer; ExcepInfo: Pointer;
      ArgErr: Pointer): HRESULT; virtual; stdcall;
  public
    constructor Create(Instance: TObject; Owned: Boolean = True);
    destructor Destroy; override;
    procedure Initialize; virtual;
    property CurrentObject : TObject read FInstance;
  end;


  TpsvComponentDispatch = class(TpsvObjectDispatch, IDispatch)
  private
    FCurrentProp : string;
  protected
    procedure GetPublishedProp; virtual;
    procedure SetPublishedProp; virtual;
    procedure RegisterPublishedProps;
  public
    function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
      Flags: Word; var Params; VarResult: Pointer; ExcepInfo: Pointer;
      ArgErr: Pointer): HRESULT; override; stdcall;
    procedure Initialize; override;
  end;


  TpsvSystemDispatch = class(TpsvComponentDispatch)
  private
   Consts : array of variant;
  protected
     {System procedures}
     procedure VarIsNullProc;
     procedure RoundProc;
     procedure TruncProc;
     procedure CopyProc;
     procedure PosProc;
     procedure LengthProc;
     {SysUtils procedures}
     procedure UpperCaseProc;
     procedure LowerCaseProc;
     procedure CompareStrProc;
     procedure CompareTextProc;
     procedure AnsiUpperCaseProc;
     procedure AnsiLowerCaseProc;
     procedure AnsiCompareStrProc;
     procedure AnsiCompareTextProc;
     procedure IsValidIdentProc;
     procedure IntToStrProc;
     procedure IntToHexProc;
     procedure StrToIntProc;
     procedure StrToIntDefProc;
     procedure FloatToStrProc;
     procedure FormatFloatProc;
     procedure StrToFloatProc;
     procedure EncodeDateProc;
     procedure EncodeTimeProc;
     procedure DayOfWeekProc;
     procedure DateProc;
     procedure TimeProc;
     procedure NowProc;
     procedure IncMonthProc;
     procedure IsLeapYearProc;
     procedure DateToStrProc;
     procedure TimeToStrProc;
     procedure DateTimeToStrProc;
     procedure StrToDateProc;
     procedure StrToTimeProc;
     procedure StrToDateTimeProc;
     procedure BeepProc;
     procedure FormatProc;
     procedure RandomProc;
     {Dialogs procedures}
     procedure ShowMessageProc;
     procedure GetPublishedProp; override;
     procedure AddConstant(AName : string; AValue : variant);
  public
    procedure Initialize; override;
  end;

 TpsvFontDispatch = class(TpsvObjectDispatch)
 protected
   procedure SetNameProp;
   procedure GetNameProp;
   procedure SetStyleProp;
   procedure GetStyleProp;
   procedure SetSizeProp;
   procedure GetSizeProp;
   procedure SetColorProp;
   procedure GetColorProp;
 public
   procedure Initialize;  override;
 end;

 TpsvControlDispatch = class(TpsvComponentDispatch)
  protected
    procedure GetFontProp;
  public
    procedure Initialize; override;
  end;


implementation



function VarToInteger(v:variant):integer;
begin
   case VarType(v) of
      varSmallint, varInteger, varByte, varError: result:=v;
      varSingle, varDouble, varCurrency, varDate: result:=round(v);
      varBoolean: if v=true then result:=1 else result:=0;
      varString, varOleStr: result:=round(StrToFloat (v));
      varUnknown, varDispatch : result := 0;
      else
         if VarIsNull(v) then
            result := 0
         else
            result := VarAsType(v,varInteger);
   end;
end;

function VarToFloat(v:variant):double;
begin
   case VarType(v) of
    varSmallint,
    varInteger,
    varByte,
    varError,
    varSingle,
    varDouble,
    varCurrency,
    varDate:   Result:=v;
    varBoolean: if v=true then result:=1 else result:=0;
    varString,varOleStr: result:= StrToFloat(v);
    varUnknown, varDispatch : result := 0;
      else
         if VarIsNull(v) then
            result := 0
         else
            result := VarAsType(v,varDouble);
   end;
end;

function VarToBoolean(v:variant):boolean;
begin
   result:=(VarToInteger(v)<>0);
end;


{ TpsvObjectDispatch }

constructor TpsvObjectDispatch.Create(Instance: TObject; Owned: Boolean);
begin
  inherited Create;
  FInstance := Instance;
  FOwned := Owned;
  FObjectInfo := TStringList.Create;
  Initialize;
end;

destructor TpsvObjectDispatch.Destroy;
var
 i : integer;
begin
  for i := 0 to FObjectInfo.Count - 1 do
   begin
     FObjectInfo.Objects[i].Free;
   end;
  FObjectInfo.Free;
  if FOwned then
    FInstance.Free;
  inherited;
end;

function TpsvObjectDispatch.GetIDsOfNames(const IID: TGUID; Names: Pointer;
  NameCount, LocaleID: Integer; DispIDs: Pointer): HRESULT;
type
  TDispIDsArray = array[0..0] of TDISPID;
  PDispIDsArray = ^TDispIDsArray;
var
  IDs: PDispIDsArray absolute DispIDs;
  i: integer;
  Name: WideString;
begin
  if NameCount > 1 then Result := DISP_E_UNKNOWNNAME
  else
    if NameCount < 1 then Result := E_INVALIDARG
    else Result := S_OK;
  for i := 0 to NameCount - 1 do
    IDs[i] := DISPID_UNKNOWN;
  if NameCount = 1 then
    begin
      Name := PWideChar(Names^);
      IDs[0] := FObjectInfo.IndexOf(Name);
       if IDs[0] = -1 then
        Result := DISP_E_UNKNOWNNAME;
    end;
end;

function TpsvObjectDispatch.GetInputArg(AIndex: integer): variant;
begin
  if (AIndex < 0) or (AIndex >= FParams^.cArgs) then
        TList.Error(SListIndexError, AIndex);
  Result := Variant(FParams^.rgvarg^[FParams^.cArgs - 1 - AIndex])
end;

function TpsvObjectDispatch.GetInputArgAsBoolean(AIndex: integer): boolean;
begin
  Result := VarToBoolean(GetInputArg(AIndex));
end;

function TpsvObjectDispatch.GetInputArgAsDateTime(
  AIndex: integer): TDateTime;
begin
   Result := VarToDateTime(GetInputArg(AIndex));
end;

function TpsvObjectDispatch.GetInputArgAsFloat(AIndex: integer): double;
begin
  Result := VarToFloat(GetInputArg(AIndex));
end;

function TpsvObjectDispatch.GetInputArgAsInteger(AIndex: integer): integer;
begin
  Result := VarToInteger(GetInputArg(AIndex));
end;

function TpsvObjectDispatch.GetInputArgAsString(AIndex: integer): string;
begin
  Result := VarToStr(GetInputArg(AIndex));
end;

function TpsvObjectDispatch.GetTypeInfo(Index, LocaleID: Integer;
  out TypeInfo): HRESULT;
begin
  Result := E_NOTIMPL;
end;

function TpsvObjectDispatch.GetTypeInfoCount(out Count: Integer): HRESULT;
begin
  Result := E_NOTIMPL;
end;

procedure TpsvObjectDispatch.Initialize;
begin
  RegisterMethod('ClassNameIs', 1, ObjectClassnameIsProc);
  RegisterMethod('ClassName', 0,  ObjectClassNameProc);
end;

function TpsvObjectDispatch.Invoke(DispID: Integer; const IID: TGUID;
  LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo,
  ArgErr: Pointer): HRESULT;

var
  OI : TpsvObjectInfo;
begin
  if not VarIsEmpty(FRetValue) then
   VarClear(FRetValue);

  Result := DISP_E_MEMBERNOTFOUND;
  if DispID >= FObjectInfo.Count then
   Exit;
  try
  FParams := @Params;
  if DispID <> -1 then
    if Flags = DISPATCH_METHOD then
      begin
        OI := TpsvObjectInfo(FObjectInfo.Objects[DispID]);
        if Assigned(OI.GetProc) then
         OI.GetProc;
      end
       else
         case Flags and not DISPATCH_METHOD of
          DISPATCH_PROPERTYGET :
            begin
              OI := TpsvObjectInfo(FObjectInfo.Objects[DispID]);
              if Assigned(OI.GetProc) then
                OI.GetProc;
            end;
          DISPATCH_PROPERTYPUT,
          DISPATCH_PROPERTYPUTREF,
          DISPATCH_PROPERTYPUT + DISPATCH_PROPERTYPUTREF:
            begin
              OI := TpsvObjectInfo(FObjectInfo.Objects[DispID]);
              if Assigned(OI.SetProc) then
                OI.SetProc;
            end;
        end;

  if not VarIsEmpty(FRetValue) then
   POleVariant(VarResult)^ := FRetValue;
  Result := S_OK;
  except
    on E : Exception do
     begin
       Result := DISP_E_EXCEPTION;
     end;
  end;
end;

procedure TpsvObjectDispatch.ObjectClassnameIsProc;
begin
  ReturnOutputArg(FInstance.ClassNameIs(GetInputArgAsString(0)) );
end;

procedure TpsvObjectDispatch.ObjectClassNameProc;
begin
  ReturnOutputArg(FInstance.ClassName);
end;


procedure TpsvObjectDispatch.RegisterMethod(AName: string;
  AParamCount: integer; AMethodProc: TDispatchProc);
var
 OI : TpsvObjectInfo;
 i : integer;
begin
 OI := TpsvObjectInfo.Create;
 OI.GetProc := AMethodProc;
 OI.ParamCount := AParamCount;
 i := FObjectInfo.Add(AName);
 FObjectInfo.Objects[i] := OI;
end;

procedure TpsvObjectDispatch.RegisterProperty(AName: string; AGet,
  ASet: TDispatchProc);
var
 OI : TpsvObjectInfo;
 i : integer;
begin
  OI := TpsvObjectInfo.Create;
  OI.GetProc := AGet;
  OI.SetProc := ASet;
  i := FObjectInfo.Add(AName);
  FObjectInfo.Objects[i] := OI;
end;

procedure TpsvObjectDispatch.ReturnOutputArg(AValue: variant);
begin
  FRetValue := AValue;
end;

{ TpsvComponentDispatch }

procedure TpsvComponentDispatch.GetPublishedProp;
begin
  ReturnOutputArg(GetPropValue(FInstance, FCurrentProp));
end;

procedure TpsvComponentDispatch.Initialize;
begin
  inherited;
  RegisterPublishedProps;
end;

function TpsvComponentDispatch.Invoke(DispID: Integer; const IID: TGUID;
  LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo,
  ArgErr: Pointer): HRESULT;
begin
  FCurrentProp := FObjectInfo[DispID];
  Result := inherited Invoke(DispID,  IID,
  LocaleID, Flags, Params, VarResult, ExcepInfo, ArgErr);
end;

procedure TpsvComponentDispatch.RegisterPublishedProps;
var
 PropList : PPropList;
 FCount : integer;
 Filter : TTypeKinds;
 FSize  : integer;
 C : integer;
begin
  if not Assigned(FInstance) then
   Exit;
  Filter := [tkInteger, tkChar, tkFloat, tkString,  tkEnumeration,
   tkWChar, tkLString, tkWString, tkVariant];
  FCount := GetPropList(FInstance.ClassInfo, Filter, nil);
  FSize := FCount * SizeOf(Pointer);
  GetMem(PropList, FSize);
  GetPropList(FInstance.ClassInfo, Filter , PropList);
  for c:=0 to FCount-1 do
   begin
     RegisterProperty(PropList^[c].Name, GetPublishedProp, SetPublishedProp);
   end;
  FreeMem(PropList, FSize);
end;

procedure TpsvComponentDispatch.SetPublishedProp;
var
 Arg : Variant;
begin
  Arg := GetInputArg(0);
  if PropIsType(FInstance, FCurrentProp, tkEnumeration) then
   begin
     if VarType(Arg) = varBoolean then
      if Arg = true then
       Arg := 1
        else
          Arg := 0;
   end;
  SetPropValue(FInstance, FCurrentProp, Arg);
end;

{ TpsvControlDispatch }

type
  TMControl = class(TControl);

procedure TpsvControlDispatch.GetFontProp;
begin
  ReturnOutputArg(TpsvFontDispatch.Create(TMControl(FInstance).Font, False) as IDispatch);
end;

procedure TpsvControlDispatch.Initialize;
begin
  inherited;
  RegisterProperty('Font', GetFontProp, nil);
end;

{ TpsvFontDispatch }

procedure TpsvFontDispatch.GetColorProp;
begin
  ReturnOutputArg(TFont(FInstance).Color);
end;

procedure TpsvFontDispatch.GetNameProp;
begin
  ReturnOutputArg(TFont(FInstance).Name);
end;

procedure TpsvFontDispatch.GetSizeProp;
begin
  ReturnOutputArg(TFont(FInstance).Size);
end;

procedure TpsvFontDispatch.GetStyleProp;
begin
  ReturnOutputArg(GetOrdProp(FInstance, 'Style'));
end;

procedure TpsvFontDispatch.Initialize;
begin
  inherited;
  RegisterProperty('Name', GetNameProp, SetNameProp);
  RegisterProperty('Size', GetSizeProp, SetSizeProp);
  RegisterProperty('Style', GetStyleProp, SetStyleProp);
  RegisterProperty('Color', GetColorProp, SetColorProp);
end;

procedure TpsvFontDispatch.SetColorProp;
begin
  TFont(FInstance).Color := GetInputArgAsInteger(0);
end;

procedure TpsvFontDispatch.SetNameProp;
begin
  TFont(FInstance).Name := GetInputArgAsString(0);
end;

procedure TpsvFontDispatch.SetSizeProp;
begin
  TFont(FInstance).Size := GetInputArgAsInteger(0);
end;

procedure TpsvFontDispatch.SetStyleProp;
begin
  SetOrdProp(FInstance, 'Style', GetInputArgAsInteger(0));
end;

{ TpsvSystemDispatch }

procedure TpsvSystemDispatch.AddConstant(AName: string; AValue: variant);
var
 L : integer;
begin
  L := Length(Consts);
  SetLength(Consts, L + 1);
  Consts[L] := AValue;
  RegisterProperty(AName, GetPublishedProp, nil);
end;


procedure TpsvSystemDispatch.GetPublishedProp;
var
 I : integer;
begin
 I := FObjectInfo.IndexOf(FCurrentProp);
 if I > -1 then
  ReturnOutputArg(Consts[i])
   else
     ReturnOutputArg(-1);
end;

procedure TpsvSystemDispatch.Initialize;
begin
  AddConstant('clScrollBar',clScrollBar);
  AddConstant('clBackground',clBackground);
  AddConstant('clActiveCaption',clActiveCaption);
  AddConstant('clInactiveCaption',clInactiveCaption);
  AddConstant('clMenu',clMenu);
  AddConstant('clWindow',clWindow);
  AddConstant('clWindowFrame',clWindowFrame);
  AddConstant('clMenuText',clMenuText);
  AddConstant('clWindowText',clWindowText);
  AddConstant('clCaptionText',clCaptionText);
  AddConstant('clActiveBorder',clActiveBorder);
  AddConstant('clInactiveBorder',clInactiveBorder);
  AddConstant('clAppWorkSpace',clAppWorkSpace);
  AddConstant('clHighlight',clHighlight);
  AddConstant('clHighlightText',clHighlightText);
  AddConstant('clBtnFace',clBtnFace);
  AddConstant('clBtnShadow',clBtnShadow);
  AddConstant('clGrayText',clGrayText);
  AddConstant('clBtnText',clBtnText);
  AddConstant('clInactiveCaptionText',clInactiveCaptionText);
  AddConstant('clBtnHighlight',clBtnHighlight);
  AddConstant('cl3DDkShadow',cl3DDkShadow);
  AddConstant('cl3DLight',cl3DLight);
  AddConstant('clInfoText',clInfoText);
  AddConstant('clInfoBk',clInfoBk);
  AddConstant('clBlack',clBlack);
  AddConstant('clMaroon',clMaroon);
  AddConstant('clGreen',clGreen);
  AddConstant('clOlive',clOlive);
  AddConstant('clNavy',clNavy);
  AddConstant('clPurple',clPurple);
  AddConstant('clTeal',clTeal);
  AddConstant('clGray',clGray);
  AddConstant('clSilver',clSilver);
  AddConstant('clRed',clRed);
  AddConstant('clLime',clLime);
  AddConstant('clYellow',clYellow);
  AddConstant('clBlue',clBlue);
  AddConstant('clFuchsia',clFuchsia);
  AddConstant('clAqua',clAqua);
  AddConstant('clLtGray',clLtGray);
  AddConstant('clDkGray',clDkGray);
  AddConstant('clWhite',clWhite);
  AddConstant('clNone',clNone);
  AddConstant('clDefault',clDefault);

  AddConstant('vbEmpty', 0);
  AddConstant('vbNull',  1);
  AddConstant('vbInteger', 2);
  AddConstant('vbLong', 3);
  AddConstant('vbSingle', 4);
  AddConstant('vbDouble', 5);
  AddConstant('vbCurrency', 6);
  AddConstant('vbDate', 7);
  AddConstant('vbString', 8);
  AddConstant('vbObject', 9);
  AddConstant('vbError', 10);
  AddConstant('vbBoolean', 11);
  AddConstant('vbVariant', 12);
  AddConstant('vbDataObject', 13);
  AddConstant('vbDecimal', 14);
  AddConstant('vbByte', 17);
  AddConstant('vbArray', 8192);



  RegisterMethod( 'UpperCase',          1,  UpperCaseProc ) ;
  RegisterMethod( 'LowerCase',          1,  LowerCaseProc );
  RegisterMethod( 'CompareStr',         2,  CompareStrProc );
  RegisterMethod( 'CompareText',        2,  CompareTextProc );
  RegisterMethod( 'AnsiUpperCase',      1,  AnsiUpperCaseProc );
  RegisterMethod( 'AnsiLowerCase',      1,  AnsiLowerCaseProc );
  RegisterMethod( 'AnsiCompareStr',     2,  AnsiCompareStrProc );
  RegisterMethod( 'AnsiCompareText',    2,  AnsiCompareTextProc );
  RegisterMethod( 'IsValidIdent',       1,  IsValidIdentProc );
  RegisterMethod( 'IntToStr',           1,  IntToStrProc );
  RegisterMethod( 'IntToHex',           2,  IntToHexProc );
  RegisterMethod( 'StrToInt',           1,  StrToIntProc );
  RegisterMethod( 'StrToIntDef',        2,  StrToIntDefProc );
  RegisterMethod( 'FloatToStr',         1,  FloatToStrProc );
  RegisterMethod( 'Format',             2,  FormatProc );
  RegisterMethod( 'FormatFloat',        2,  FormatFloatProc );
  RegisterMethod( 'StrToFloat',         1,  StrToFloatProc );
  RegisterMethod( 'EncodeDate',         3,  EncodeDateProc );
  RegisterMethod( 'EncodeTime',         4,  EncodeTimeProc );
  RegisterMethod( 'DayOfWeek',          1,  DayOfWeekProc );
  RegisterMethod( 'Date',               0,  DateProc );
  RegisterMethod( 'Time',               0,  TimeProc );
  RegisterMethod( 'Now',                0,  NowProc );
  RegisterMethod( 'IncMonth',           2,  IncMonthProc );
  RegisterMethod( 'IsLeapYear',         1,  IsLeapYearProc );
  RegisterMethod( 'DateToStr',          1,  DateToStrProc );
  RegisterMethod( 'TimeToStr',          1,  TimeToStrProc );
  RegisterMethod( 'DateTimeToStr',      1,  DateTimeToStrProc );
  RegisterMethod( 'StrToDate',          1,  StrToDateProc );
  RegisterMethod( 'StrToTime',          1,  StrToTimeProc );
  RegisterMethod( 'StrToDateTime',      1,  StrToDateTimeProc );
  RegisterMethod( 'Beep',               0,  BeepProc );
  RegisterMethod( 'VarIsNull',          1,  VarIsNullProc );
  RegisterMethod( 'Round',              1,  RoundProc );
  RegisterMethod( 'Trunc',              1,  TruncProc );
  RegisterMethod( 'Copy',               3,  CopyProc );
  RegisterMethod( 'Pos',                2,  PosProc );
  RegisterMethod( 'Length',             1,  LengthProc );
  RegisterMethod( 'ShowMessage',        1,  ShowMessageProc );
  RegisterMethod( 'Random',             0,  RandomProc );

  inherited;
end;



procedure TpsvSystemDispatch.UpperCaseProc;
begin
   ReturnOutputArg( UpperCase( GetInputArgAsString( 0 ) ) );
end;

procedure TpsvSystemDispatch.LowerCaseProc;
begin
   ReturnOutputArg( LowerCase( GetInputArgAsString( 0 ) ) );
end;

procedure TpsvSystemDispatch.CompareStrProc;
begin
  ReturnOutputArg( CompareStr( GetInputArgAsString( 0 ),GetInputArgAsString( 1 ) ) );
end;

procedure TpsvSystemDispatch.CompareTextProc;
begin
   ReturnOutputArg( CompareText( GetInputArgAsString( 0 ),GetInputArgAsString( 1 ) ) );
end;

procedure TpsvSystemDispatch.AnsiUpperCaseProc;
begin
  ReturnOutputArg( AnsiUpperCase( GetInputArgAsString( 0 ) ) );
end;

procedure TpsvSystemDispatch.AnsiLowerCaseProc;
begin
  ReturnOutputArg( AnsiLowerCase( GetInputArgAsString( 0 ) ) );
end;

procedure TpsvSystemDispatch.AnsiCompareStrProc;
begin
  ReturnOutputArg( AnsiCompareStr( GetInputArgAsString( 0 ),GetInputArgAsString( 1 ) ) );
end;

procedure TpsvSystemDispatch.AnsiCompareTextProc;
begin
   ReturnOutputArg( AnsiCompareText( GetInputArgAsString( 0 ),GetInputArgAsString( 1 ) ) );
end;


procedure TpsvSystemDispatch.IsValidIdentProc;
begin
  ReturnOutputArg( IsValidIdent( GetInputArgAsString( 0 ) ) );
end;

procedure TpsvSystemDispatch.IntToStrProc;
begin
  ReturnOutputArg( IntToStr( GetInputArgAsInteger( 0 ) ) );
end;

procedure TpsvSystemDispatch.IntToHexProc;
begin
  ReturnOutputArg( IntToHex( GetInputArgAsInteger( 0 ),GetInputArgAsInteger( 1 ) ) );
end;

procedure TpsvSystemDispatch.StrToIntProc;
begin
  ReturnOutputArg( StrToInt( GetInputArgAsString( 0 ) ) );
end;

procedure TpsvSystemDispatch.StrToIntDefProc;
begin
  ReturnOutputArg( StrToIntDef( GetInputArgAsString( 0 ),GetInputArgAsInteger( 1 ) ) );
end;

procedure TpsvSystemDispatch.FloatToStrProc;
begin
  ReturnOutputArg( FloatToStr( GetInputArgAsFloat( 0 ) ) );
end;

procedure TpsvSystemDispatch.FormatFloatProc;
begin
  ReturnOutputArg( FormatFloat( GetInputArgAsString( 0 ),GetInputArgAsFloat( 1 ) ) );
end;

procedure TpsvSystemDispatch.StrToFloatProc;
begin
  ReturnOutputArg( StrToFloat( GetInputArgAsString( 0 ) ) );
end;

procedure TpsvSystemDispatch.EncodeDateProc;
begin
  ReturnOutputArg( EncodeDate(
         GetInputArgAsInteger( 0 ),
         GetInputArgAsInteger( 1 ),
         GetInputArgAsInteger( 2 ) ) );
end;

procedure TpsvSystemDispatch.EncodeTimeProc;
begin
  ReturnOutputArg( EncodeTime(
         GetInputArgAsInteger( 0 ),
         GetInputArgAsInteger( 1 ),
         GetInputArgAsInteger( 2 ),
         GetInputArgAsInteger( 3 ) ) );
end;



procedure TpsvSystemDispatch.DayOfWeekProc;
begin
  ReturnOutputArg( DayOfWeek( GetInputArgAsDateTime( 0 ) ) );
end;

procedure TpsvSystemDispatch.DateProc;
begin
  ReturnOutputArg( Date );
end;

procedure TpsvSystemDispatch.TimeProc;
begin
  ReturnOutputArg( Time );
end;

procedure TpsvSystemDispatch.NowProc;
begin
  ReturnOutputArg( Now );
end;

procedure TpsvSystemDispatch.IncMonthProc;
begin
  ReturnOutputArg( IncMonth( GetInputArgAsDateTime( 0 ),GetInputArgAsInteger( 1 ) ) );
end;

procedure TpsvSystemDispatch.IsLeapYearProc;
begin
  ReturnOutputArg( IsLeapYear( GetInputArgAsInteger( 0 ) ) );
end;

procedure TpsvSystemDispatch.DateToStrProc;
begin
  ReturnOutputArg( DateToStr( GetInputArgAsDateTime( 0 ) ) );
end;

procedure TpsvSystemDispatch.TimeToStrProc;
begin
  ReturnOutputArg( TimeToStr( GetInputArgAsDateTime( 0 ) ) );
end;

procedure TpsvSystemDispatch.DateTimeToStrProc;
begin
  ReturnOutputArg( DateTimeToStr( GetInputArgAsDateTime( 0 ) ) );
end;

procedure TpsvSystemDispatch.StrToDateProc;
begin
  ReturnOutputArg( StrToDate( GetInputArgAsString( 0 ) ) );
end;

procedure TpsvSystemDispatch.StrToTimeProc;
begin
  ReturnOutputArg( StrToTime( GetInputArgAsString( 0 ) ) );
end;

procedure TpsvSystemDispatch.StrToDateTimeProc;
begin
  ReturnOutputArg( StrToDateTime( GetInputArgAsString( 0 ) ) );
end;


procedure TpsvSystemDispatch.BeepProc;
begin
  Beep;
end;

procedure TpsvSystemDispatch.VarIsNullProc;
begin
  ReturnOutputArg( VarIsNull( GetInputArg( 0 ) ) );
end;

procedure TpsvSystemDispatch.RoundProc;
begin
  ReturnOutputArg( Integer(Round( GetInputArgAsFloat( 0 ) )) );
end;

procedure TpsvSystemDispatch.TruncProc;
begin
  ReturnOutputArg( Integer(Trunc( GetInputArgAsFloat( 0 ) )) );
end;

procedure TpsvSystemDispatch.CopyProc;
begin
  ReturnOutputArg( Copy(
         GetInputArgAsString( 0 ),
         GetInputArgAsInteger( 1 ),
         GetInputArgAsInteger( 2 ) ) );
end;


procedure TpsvSystemDispatch.PosProc;
begin
  ReturnOutputArg( pos(GetInputArgAsString( 0 ),GetInputArgAsString( 1 )) );
end;

procedure TpsvSystemDispatch.LengthProc;
begin
  ReturnOutputArg( Length( GetInputArgAsString( 0 ) ) );
end;

procedure TpsvSystemDispatch.ShowMessageProc;
begin
   ShowMessage( GetInputArgAsString( 0 ) );
end;

procedure TpsvSystemDispatch.RandomProc;
begin
  ReturnOutputArg( Random );
end;

procedure TpsvSystemDispatch.FormatProc;
var args  : array of TVarRec;
    v     : variant;
    lo,hi : integer;
    c     : integer;
    pvar  : ^variant;
begin
   begin
      v:=GetInputArg(1);
      if VarArrayDimCount(v)=1 then
      begin
         lo:=VarArrayLowBound(v,1);
         hi:=VarArrayHighBound(v,1);
         SetLength(args,hi-lo+1);
         pvar := VarArrayLock(v);
         try
            for c:=lo to hi do
            begin
               with TVarData(pvar^) do
                  case VType of
                     varByte,
                     varSmallint,
                     varInteger :
                        begin
                           args[c-lo].VInteger:=pvar^;
                           args[c-lo].VType:=vtInteger;
                        end;
                     varDate,
                     varSingle,
                     varDouble :
                        begin
                           New(args[c-lo].VExtended);
                           args[c-lo].VExtended^:=VDouble;
                           args[c-lo].VType:=vtExtended;
                        end;
                     varCurrency :
                        begin
                           args[c-lo].VCurrency:=@VCurrency;
                           args[c-lo].VType:=vtCurrency;
                        end;
                     varBoolean :
                        begin
                           args[c-lo].VBoolean:=pvar^;
                           args[c-lo].VType:=vtBoolean;
                        end;
                     varOleStr,
                     varStrArg :
                        begin
                           args[c].VPWideChar := VOleStr;
                           args[c].VType := vtPWideChar;
                        end;
                     varString :
                        begin
                           args[c-lo].VAnsiString := VString;
                           args[c-lo].VType := vtAnsiString;
                        end;
                     else begin Raise Exception.Create('Illegal argument to Format function'); end;
                  end;
               inc(pvar);
            end;

            ReturnOutputArg(Format(GetInputArgAsString(0),args));
         finally
            for c:=hi downto lo do
            begin
               dec(pvar);
               with TVarData(pvar^) do
                  case VType of
                     varDate, varSingle, varDouble :
                        Dispose(args[c-lo].VExtended);
                  end;
            end;
            VarArrayUnlock(v);
         end;
      end
      else
         begin  raise Exception.Create('Format function expects second argument as a variant vector'); end;
   end;
end;


end.

Regards,
Serhiy Perevoznyk, author of psvActiveScript
0
 

Author Comment

by:werehamster-
ID: 12141683
I think this will solve my problems, but going to leave up the question for a little longer case anyone else has any quick tips they can give me.

Also, with this, I can hav emore than one script going at once I assume?  Or should I queue it?  Basically going to have a whole bunch of events such as...

UserTalk
UserWhisper
UserEmote
SytemMessage
OnTimer
Etc.

And things will be going by VERY fast.  Most of this stuff will be triggered from an indy TCP reader thread and a timer.  Is this supposed to be Thread safe or should I use synchronize?  I probalbly need it synchronized for the memo.lines.add anyway.
0
 
LVL 2

Expert Comment

by:php4delphi
ID: 12142441
OK, I have very easy solution, but strongly Delphi 7 oriented

unit myunit;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, psvActiveScript;

type
  {$METHODINFO ON}
  TDemo = class(TForm)
    psvActiveScriptWindow: TpsvActiveScriptWindow;
    Button1: TButton;
    Memo1: TMemo;
    Memo2: TMemo;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
    Username, Flags, _Message, Ping : string;
    procedure DisplayString(S : String);
    function Blah : string;
  end;
  {$METHODINFO OFF}

var
  Demo: TDemo;

implementation

{$R *.dfm}

uses
 ObjComAuto;

function TDemo.Blah: string;
begin
  Result := 'Blah';
end;

procedure TDemo.Button1Click(Sender: TObject);
var
 DOB : TObjectDispatch;
begin
   UserName := 'ginsonic';
   Flags := '0';
   _Message := 'Hello';
   Ping := 'Ping';

  DOB := TObjectDispatch.Create(Demo, false);
  psvActiveScriptWindow.AddNamedItem('Demo', DOB);

  //just for demo
  Memo2.Clear;
  Memo2.Lines.Add('Event_UserTalk "' + UserName +
  '", "' + Flags + '", "' + _Message + '", "' + Ping + '"');
  Memo2.Lines.Add('Sub Event_UserTalk(Username, Flags, Message, Ping)');
  Memo2.Lines.Add('Demo.DisplayString "Hi "&Username&" Hi!"');
  Memo2.Lines.Add('Call Demo.DisplayString("My favorite word is "&Demo.Blah&"!")');
  Memo2.Lines.Add('End Sub');


  //event occurs, execute script

  psvActiveScriptWindow.Execute(Memo2.Text);

end;

procedure TDemo.DisplayString(S: String);
begin
  Memo1.Lines.Add(S);
end;

end.

If you are going to use a threads in your application you have to synchronize for memo.lines.add
You can create an instance of psvActiveScriptWindow for every thread to avoid synchronization of the scripting engine (anyway the values of the variables in your script must be unique for every thread)
0
 

Author Comment

by:werehamster-
ID: 12153689
Alright, I'm still missing one crucial piece of information....


How do I execute a specific function or sub with parameters without having to rewrite the script each time?

I mean, if I have an OnChat event, how do I call a sub inside the script

Sub OnChat(Name, Text)
End Sub

Where I give it a name and text during runtime?  All the examples I've seen, run with the variables inside the script already and not passing anything into the script.
0
 
LVL 2

Expert Comment

by:php4delphi
ID: 12155091
psvActiveScript has a property ScriptInterface. It is a Dispatch interface of script engine. You can use it to assign value to the variables and to call specific functions and procedures. In this case you can write one long script with all functions you will need and call specific functions in your event handlers at run-time.

0
 

Author Comment

by:werehamster-
ID: 12156724
Yes, but how do I pass values to those functions at run-time?

Do I have to make functions that don't have parameters using globals that I change or something to simulate it, and then call the OnEvent(params) functions from there?
0
 

Author Comment

by:werehamster-
ID: 12156739
I just need to know how to call a specific sub/function in the script with PARAMETERS during RUN-TIME.  Is this possible?  It is really what I've been asking from the start.  I don't mean to seem rude, just trying to get this done.  :)
0
 
LVL 2

Accepted Solution

by:
php4delphi earned 450 total points
ID: 12167887
I made some changes to psvActive script to access the script at run-time in more easy way
and a small example, based on one of the previous messages how to call VB functions directly from the
Delphi application without modification to the script's text.

{*******************************************************}
{                psvActiveScript library                }
{                     version 1.1                       }
{ Author:                                               }
{ Serhiy Perevoznyk                                     }
{ serge_perevoznyk@hotmail.com                          }
{                                                       }
{*******************************************************}

(* ***** BEGIN LICENSE BLOCK *****
 * Version: MPL 1.1
 *
 * The contents of this file are subject to the Mozilla Public License Version
 * 1.1 (the "License"); you may not use this file except in compliance with
 * the License. You may obtain a copy of the License at
 * http://www.mozilla.org/MPL/
 *
 * Software distributed under the License is distributed on an "AS IS" basis,
 * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
 * for the specific language governing rights and limitations under the
 * License.
 *
 * The Original Code is psvActiveScript Library
 *
 * The Initial Developer of the Original Code is
 * Serhiy Perevoznyk
 *
 *
 * ***** END LICENSE BLOCK ***** *)

unit psvActiveScript;

interface

uses
  Windows, SysUtils, ActiveX, ComObj, Contnrs, Classes,
  {$IFNDEF VER130}
  Variants,
  {$ENDIF}
  Forms;

const
  SCATID_ActiveScript =               '{F0B7A1A1-9847-11cf-8F20-00805F2CD064}';
  SCATID_ActiveScriptParse =          '{F0B7A1A2-9847-11cf-8F20-00805F2CD064}';
  SID_IActiveScript =                 '{BB1A2AE1-A4F9-11cf-8F20-00805F2CD064}';
  SID_IActiveScriptParse =            '{BB1A2AE2-A4F9-11cf-8F20-00805F2CD064}';
  SID_IActiveScriptParseProcedureOld ='{1CFF0050-6FDD-11d0-9328-00A0C90DCAA9}';
  SID_IActiveScriptParseProcedure =   '{AA5B6A80-B834-11d0-932F-00A0C90DCAA9}';
  SID_IActiveScriptSite =             '{DB01A1E3-A42B-11cf-8F20-00805F2CD064}';
  SID_IActiveScriptSiteWindow =       '{D10F6761-83E9-11cf-8F20-00805F2CD064}';
  SID_IActiveScriptSiteInterruptPoll ='{539698A0-CDCA-11CF-A5EB-00AA0047A063}';
  SID_IActiveScriptError =            '{EAE1BA61-A4ED-11cf-8F20-00805F2CD064}';
  SID_IBindEventHandler =             '{63CDBCB0-C1B1-11d0-9336-00A0C90DCAA9}';
  SID_IActiveScriptStats =            '{B8DA6310-E19B-11d0-933C-00A0C90DCAA9}';

  CATID_ActiveScript:                 TGUID = SCATID_ActiveScript;
  CATID_ActiveScriptParse:            TGUID = SCATID_ActiveScriptParse;
  IID_IActiveScript:                  TGUID = SID_IActiveScript;
  IID_IActiveScriptParse:             TGUID = SID_IActiveScriptParse;
  IID_IActiveScriptParseProcedureOld: TGUID = SID_IActiveScriptParseProcedureOld;
  IID_IActiveScriptParseProcedure:    TGUID = SID_IActiveScriptParseProcedure;
  IID_IActiveScriptSite:              TGUID = SID_IActiveScriptSite;
  IID_IActiveScriptSiteWindow:        TGUID = SID_IActiveScriptSiteWindow;
  IID_IActiveScriptSiteInterruptPoll: TGUID = SID_IActiveScriptSiteInterruptPoll;
  IID_IActiveScriptError:             TGUID = SID_IActiveScriptError;
  IID_IBindEventHandler:              TGUID = SID_IBindEventHandler;
  IID_IActiveScriptStats:             TGUID = SID_IActiveScriptStats;

// Constants used by ActiveX Scripting:
//

(* IActiveScript::AddNamedItem() input flags *)

  SCRIPTITEM_ISVISIBLE     = $00000002;
  SCRIPTITEM_ISSOURCE      = $00000004;
  SCRIPTITEM_GLOBALMEMBERS = $00000008;
  SCRIPTITEM_ISPERSISTENT  = $00000040;
  SCRIPTITEM_CODEONLY      = $00000200;
  SCRIPTITEM_NOCODE        = $00000400;
  SCRIPTITEM_ALL_FLAGS     =(SCRIPTITEM_ISSOURCE or
                             SCRIPTITEM_ISVISIBLE or
                             SCRIPTITEM_ISPERSISTENT or
                             SCRIPTITEM_GLOBALMEMBERS or
                             SCRIPTITEM_NOCODE or
                             SCRIPTITEM_CODEONLY);

(* IActiveScript::AddTypeLib() input flags *)

  SCRIPTTYPELIB_ISCONTROL    = $00000010;
  SCRIPTTYPELIB_ISPERSISTENT = $00000040;
  SCRIPTTYPELIB_ALL_FLAGS    = (SCRIPTTYPELIB_ISCONTROL or
                                SCRIPTTYPELIB_ISPERSISTENT);

(* IActiveScriptParse::AddScriptlet() and
   IActiveScriptParse::ParseScriptText() input flags *)

  SCRIPTTEXT_DELAYEXECUTION    = $00000001;
  SCRIPTTEXT_ISVISIBLE         = $00000002;
  SCRIPTTEXT_ISEXPRESSION      = $00000020;
  SCRIPTTEXT_ISPERSISTENT      = $00000040;
  SCRIPTTEXT_HOSTMANAGESSOURCE = $00000080;
  SCRIPTTEXT_ALL_FLAGS         = (SCRIPTTEXT_DELAYEXECUTION or
                                  SCRIPTTEXT_ISVISIBLE or
                                  SCRIPTTEXT_ISEXPRESSION or
                                  SCRIPTTEXT_ISPERSISTENT or
                                  SCRIPTTEXT_HOSTMANAGESSOURCE);

(* IActiveScriptParseProcedure::ParseProcedureText() input flags *)

  SCRIPTPROC_HOSTMANAGESSOURCE = $00000080;
  SCRIPTPROC_IMPLICIT_THIS     = $00000100;
  SCRIPTPROC_IMPLICIT_PARENTS  = $00000200;
  SCRIPTPROC_ALL_FLAGS         = (SCRIPTPROC_HOSTMANAGESSOURCE or
                                  SCRIPTPROC_IMPLICIT_THIS or
                                  SCRIPTPROC_IMPLICIT_PARENTS);

(* IActiveScriptSite::GetItemInfo() input flags *)

  SCRIPTINFO_IUNKNOWN  = $00000001;
  SCRIPTINFO_ITYPEINFO = $00000002;
  SCRIPTINFO_ALL_FLAGS = (SCRIPTINFO_IUNKNOWN or
                          SCRIPTINFO_ITYPEINFO);

(* IActiveScript::Interrupt() Flags *)

  SCRIPTINTERRUPT_DEBUG          = $00000001;
  SCRIPTINTERRUPT_RAISEEXCEPTION = $00000002;
  SCRIPTINTERRUPT_ALL_FLAGS      = (SCRIPTINTERRUPT_DEBUG or
                                    SCRIPTINTERRUPT_RAISEEXCEPTION);

(* IActiveScriptStats::GetStat() values *)

  SCRIPTSTAT_STATEMENT_COUNT   = 1;
  SCRIPTSTAT_INSTRUCTION_COUNT = 2;
  SCRIPTSTAT_INTSTRUCTION_TIME = 3;
  SCRIPTSTAT_TOTAL_TIME        = 4;

(* script state values *)

type
  tagSCRIPTSTATE = integer;
  SCRIPTSTATE = tagSCRIPTSTATE;
const
  SCRIPTSTATE_UNINITIALIZED = $00000000;
  SCRIPTSTATE_INITIALIZED   = $00000005;
  SCRIPTSTATE_STARTED       = $00000001;
  SCRIPTSTATE_CONNECTED     = $00000002;
  SCRIPTSTATE_DISCONNECTED  = $00000003;
  SCRIPTSTATE_CLOSED        = $00000004;

(* script thread state values *)

type
  tagSCRIPTTHREADSTATE = integer;
  SCRIPTTHREADSTATE = tagSCRIPTTHREADSTATE;
const
  SCRIPTTHREADSTATE_NOTINSCRIPT = $00000000;
  SCRIPTTHREADSTATE_RUNNING     = $00000001;

(* Thread IDs *)

type
  SCRIPTTHREADID = DWORD;
const
  SCRIPTTHREADID_CURRENT = SCRIPTTHREADID(-1);
  SCRIPTTHREADID_BASE    = SCRIPTTHREADID(-2);
  SCRIPTTHREADID_ALL     = SCRIPTTHREADID(-3);

type
  IActiveScriptSite =           interface;
  IActiveScriptSiteWindow =     interface;
  IActiveScript =               interface;
  IActiveScriptParse =          interface;
  IActiveScriptParseProcedure = interface;
  IActiveScriptError =          interface;
  LPCOLESTR = PWideChar;

  IActiveScriptSite = interface(IUnknown)
    [SID_IActiveScript]
    function GetLCID(out plcid: LCID): HResult; stdcall;
    function GetItemInfo(
      pstrName: LPCOLESTR;
      dwReturnMask: DWORD;
      out ppiunkItem: IUnknown;
      out ppti: ITypeInfo): HResult; stdcall;
    function GetDocVersionString(out pbstrVersion: WideString): HResult; stdcall;
    function OnScriptTerminate(
      var pvarResult: OleVariant;
      var pexcepinfo: EXCEPINFO): HResult; stdcall;
    function OnStateChange(ssScriptState: SCRIPTSTATE): HResult; stdcall;
    function OnScriptError(
      const pscripterror: IActiveScriptError): HResult; stdcall;
    function OnEnterScript: HResult; stdcall;
    function OnLeaveScript: HResult; stdcall;
  end;

  IActiveScriptError = interface(IUnknown)
    [SID_IActiveScriptError]
    function GetExceptionInfo(out pexcepinfo: EXCEPINFO): HResult; stdcall;
    function GetSourcePosition(
      out pdwSourceContext: DWORD;
      out pulLineNumber: ULONG;
      out plCharacterPosition: Integer): HResult; stdcall;
    function GetSourceLineText(out pbstrSourceLine: WideString): HResult; stdcall;
  end;

  IActiveScriptSiteWindow = interface(IUnknown)
    [SID_IActiveScriptSiteWindow]
    function GetWindow(out phwnd: HWND): HResult; stdcall;
    function EnableModeless(fEnable: BOOL): HResult; stdcall;
  end;

  IActiveScriptSiteInterruptPoll = interface(IUnknown)
    [SID_IActiveScriptSiteInterruptPoll]
    function QueryContinue: HResult; stdcall;
  end;

  IActiveScript = interface(IUnknown)
    [SID_IActiveScript]
    function SetScriptSite(const pass: IActiveScriptSite): HResult; stdcall;
    function GetScriptSite(
      const riid: TGUID;
      out ppvObject: Pointer): HResult; stdcall;
    function SetScriptState(ss: SCRIPTSTATE): HResult; stdcall;
    function GetScriptState(out pssState: SCRIPTSTATE): HResult; stdcall;
    function Close: HResult; stdcall;
    function AddNamedItem(
      pstrName: LPCOLESTR;
      dwFlags: DWORD): HResult; stdcall;
    function AddTypeLib(
      const rguidTypeLib: TGUID;
      dwMajor: DWORD;
      dwMinor: DWORD;
      dwFlags: DWORD): HResult; stdcall;
    function GetScriptDispatch(
      pstrItemName: LPCOLESTR;
      out ppdisp: IDispatch): HResult; stdcall;
    function GetCurrentScriptThreadID(
      out pstidThread: SCRIPTTHREADID): HResult; stdcall;
    function GetScriptThreadID(dwWin32ThreadId: DWORD;
      out pstidThread: SCRIPTTHREADID): HResult; stdcall;
    function GetScriptThreadState(
      stidThread: SCRIPTTHREADID;
      out pstsState: SCRIPTTHREADSTATE): HResult; stdcall;
    function InterruptScriptThread(
      stidThread: SCRIPTTHREADID;
      var pexcepinfo: EXCEPINFO;
      dwFlags: DWORD): HResult; stdcall;
    function Clone(out ppscript: IActiveScript): HResult; stdcall;
  end;

  IActiveScriptParse = interface(IUnknown)
    [SID_IActiveScriptParse]
    function InitNew: HResult; stdcall;
    function AddScriptlet(
      pstrDefaultName: LPCOLESTR;
      pstrCode: LPCOLESTR;
      pstrItemName: LPCOLESTR;
      pstrSubItemName: LPCOLESTR;
      pstrEventName: LPCOLESTR;
      pstrDelimiter: LPCOLESTR;
      dwSourceContextCookie: DWORD;
      ulStartingLineNumber: ULONG;
      dwFlags: DWORD;
      out pbstrName: WideString;
      out pexcepinfo: EXCEPINFO): HResult; stdcall;
    function ParseScriptText(
      pstrCode: LPCOLESTR;
      pstrItemName: LPCOLESTR;
      const punkContext: IUnknown;
      pstrDelimiter: LPCOLESTR;
      dwSourceContextCookie: DWORD;
      ulStartingLineNumber: ULONG;
      dwFlags: DWORD;
      out pvarResult: OleVariant;
      out pexcepinfo: EXCEPINFO): HResult; stdcall;
  end;

  IActiveScriptParseProcedureOld = interface(IUnknown)
    [SID_IActiveScriptParseProcedureOld]
    function ParseProcedureText(
      pstrCode: LPCOLESTR;
      pstrFormalParams: LPCOLESTR;
      pstrItemName: LPCOLESTR;
      const punkContext: IUnknown;
      pstrDelimiter: LPCOLESTR;
      dwSourceContextCookie: DWORD;
      ulStartingLineNumber: ULONG;
      dwFlags: DWORD;
      out ppdisp: IDispatch): HResult; stdcall;
  end;

  IActiveScriptParseProcedure = interface(IUnknown)
    [SID_IActiveScriptParseProcedure]
    function ParseProcedureText(
      pstrCode: LPCOLESTR;
      pstrFormalParams: LPCOLESTR;
      pstrProcedureName: LPCOLESTR;
      pstrItemName: LPCOLESTR;
      const punkContext: IUnknown;
      pstrDelimiter: LPCOLESTR;
      dwSourceContextCookie: DWORD;
      ulStartingLineNumber: ULONG;
      dwFlags: DWORD;
      out ppdisp: IDispatch): HResult; stdcall;
  end;

  IBindEventHandler = interface(IUnknown)
    [SID_IBindEventHandler]
    function BindHandler(
      pstrEvent: LPCOLESTR;
      const pdisp: IDispatch): HResult; stdcall;
  end;

  IActiveScriptStats = interface(IUnknown)
    [SID_IActiveScriptStats]
    function GetStat(
      stid: DWORD;
      out pluHi: ULONG;
      out pluLo: ULONG): HResult; stdcall;
    function GetStatEx(
      const guid: TGUID;
      out pluHi: ULONG;
      out pluLo: ULONG): HResult; stdcall;
    function ResetStats: HResult; stdcall;
  end;

type
 TOnActiveScriptError = procedure(Sender : TObject; Line, Pos : integer; ASrc : string; ADescription : string) of object;

  TpsvScriptGlobalObjects = class(TObject)
  private
    FIntfList: IInterfaceList;
    FNamedList: TStrings;
  public
    constructor Create;
    function GetNamedItemCount: Integer;
    function GetNamedItemName(I: Integer): string;
    procedure AddNamedIntf(const AName: string; AIntf: IUnknown);
    function FindNamedItemIntf(const AName: string): IUnknown;
    destructor Destroy; override;
    property NamedItemCount: Integer read GetNamedItemCount;
    property NamedItemName[I: Integer]: string read GetNamedItemName;
  end;

  TpsvActiveScriptSite = class(TComponent, IActiveScriptSite)
  private
    FOnCreateScriptEngine : TNotifyEvent;
    FUseSafeSubset : boolean;
    FDisp: OleVariant;
    FGlobalObjects : TpsvScriptGlobalObjects;
    FOnError : TOnActiveScriptError;
    FEngine: IActiveScript;
    FParser: IActiveScriptParse;
    FScriptLanguage : string;
    procedure CreateScriptEngine(Language: string);
    procedure CloseScriptEngine;
  protected
    { IActiveScriptSite }
    function  GetLCID(out plcid: LongWord): HResult; stdcall;
    function GetItemInfo(
      pstrName: LPCOLESTR;
      dwReturnMask: DWORD;
      out ppiunkItem: IUnknown;
      out ppti: ITypeInfo): HResult; stdcall;
    function  GetDocVersionString(out pbstrVersion: WideString): HResult; stdcall;
    function  OnScriptTerminate(var pvarResult: OleVariant; var pexcepinfo: EXCEPINFO): HResult; stdcall;
    function  OnStateChange(ssScriptState: tagSCRIPTSTATE): HResult; stdcall;
    function  OnScriptError(const pscripterror: IActiveScriptError): HResult; stdcall;
    function  OnEnterScript: HResult; stdcall;
    function  OnLeaveScript: HResult; stdcall;
  public
    constructor Create(AOwner : TComponent); override;
    destructor Destroy; override;
    function   RunExpression(ACode : Widestring) : string;
    procedure  Execute(ACode : WideString);
    procedure  AddNamedItem(AName : string; AIntf : IUnknown);
    property   ScriptInterface : OleVariant read FDisp;
    property   Engine : IActiveScript read FEngine;
  published
    property ScriptLanguage : string read FScriptLanguage write FScriptLanguage;
    property OnError : TOnActiveScriptError read FOnError write FOnError;
    property UseSafeSubset : boolean read FUseSafeSubset write FUseSafeSubset default false;
    property OnCreateScriptEngine : TNotifyEvent read FOnCreateScriptEngine write FOnCreateScriptEngine;
  end;

  TpsvActiveScriptWindow = class(TpsvActiveScriptSite, IActiveScriptSiteWindow)
  protected
    {IActiveSriptSiteWindow}
    function GetWindow(out phwnd: HWND): HResult; stdcall;
    function EnableModeless(fEnable: BOOL): HResult; stdcall;
  end;

procedure GetActiveScriptParse(List: TStrings);


implementation

const
  INTERFACESAFE_FOR_UNTRUSTED_CALLER = $00000001  // Caller of interface may be untrusted
  ;
  INTERFACESAFE_FOR_UNTRUSTED_DATA = $00000002  // Data passed into interface may be untrusted
  ;
  INTERFACE_USES_DISPEX = $00000004  // Object knows to use IDispatchEx
  ;
  INTERFACE_USES_SECURITY_MANAGER = $00000008  // Object knows to use IInternetHostSecurityManager
  ;


procedure GetActiveScriptParse(List: TStrings);
var
  ProgID: string;

  function ValidProgID: Boolean;
  var
    PID: string;
  begin
     if Length(ProgID) > 7 then
       Result := AnsiCompareStr('.Encode', Copy(ProgID, Length(ProgID)-6, 7)) <> 0
     else
       Result := True;
     // Exclude XML script engine
     if CompareText(Copy(ProgID, 1, 3), 'XML') = 0 then
       Result := False;
     // Exclude "signed" script engines
     PID := UpperCase(ProgID);
     if Pos('SIGNED', PID) <> 0 then
       Result := False;
  end;
var
  EnumGUID: IEnumGUID;
  Fetched: Cardinal;
  Guid: TGUID;
  Rslt: HResult;
  CatInfo: ICatInformation;
  I, BufSize: Integer;
  ClassIDKey: HKey;
  S: string;
  Buffer: array[0..255] of Char;
begin
  List.Clear;
  Rslt := CoCreateInstance(CLSID_StdComponentCategoryMgr, nil,
    CLSCTX_INPROC_SERVER, ICatInformation, CatInfo);
  if Succeeded(Rslt) then
  begin
    OleCheck(CatInfo.EnumClassesOfCategories(1, @CATID_ActiveScriptParse, 0, nil, EnumGUID));
    while EnumGUID.Next(1, Guid, Fetched) = S_OK do
    begin
      try
        ProgID := ClassIDToProgID(Guid);
        if ValidProgID then
          List.Add(ProgID);
      except
        ProgID := ClassIDToProgID(StringToGUID(Buffer));
        List.Add('Invalid Entry In Categories');
      end;
    end;
  end else
  begin
    if RegOpenKey(HKEY_CLASSES_ROOT, 'CLSID', ClassIDKey) <> 0 then
      try
        I := 0;
        while RegEnumKey(ClassIDKey, I, Buffer, SizeOf(Buffer)) = 0 do
        begin
          S := Format('%s\Implemented Categories\%s',[Buffer,  { do not localize }
            GUIDToString(CATID_ActiveScriptParse)]);
          if RegQueryValue(ClassIDKey, PChar(S), nil, BufSize) = 0 then
          begin
            ProgID := ClassIDToProgID(StringToGUID(Buffer));
            if ValidProgID then
              List.Add(ProgID);
          end;
          Inc(I);
        end;
      finally
        RegCloseKey(ClassIDKey);
      end;
  end;
end;

{ TpsvActiveScriptSite }


constructor TpsvActiveScriptSite.Create(AOwner : TComponent);
begin
  inherited;
  FScriptLanguage := 'VBScript';
  FGlobalObjects := TpsvScriptGlobalObjects.Create;
  FUseSafeSubset := false;
end;

destructor TpsvActiveScriptSite.Destroy;
begin
  CloseScriptEngine;
  FGlobalObjects.Free;
  inherited;
end;

procedure TpsvActiveScriptSite.AddNamedItem(AName: string;
  AIntf: IUnknown);
begin
  FGlobalObjects.AddNamedIntf(AName, AIntf);
end;



procedure TpsvActiveScriptSite.CreateScriptEngine(
  Language: string);
const
  NULL_GUID: TGUID = '{00000000-0000-0000-0000-000000000000}';
var
  ScriptCLSID : TGUID;
  LanguageW : WideString;
  hr : HRESULT;
  i : integer;
  Disp: IDispatch;
  pOs : IObjectSafety;
  dwSupported : DWORD;
  dwEnabled : DWORD;
begin
  CloseScriptEngine;
  LanguageW := Language;
  if CLSIDFromProgID(PWideChar(LanguageW), ScriptCLSID) <> S_OK
    then ScriptCLSID := NULL_GUID;
  FEngine := CreateComObject(ScriptCLSID) as IActiveScript;
  if FUseSafeSubset then
   begin
     dwSupported := 0;
     dwEnabled := 0;
     FEngine.QueryInterface(IObjectSafety, pOS);
     if Assigned(pOS) then
      begin
        pOS.GetInterfaceSafetyOptions(IDispatch, @dwSupported, @dwEnabled);
          if (INTERFACE_USES_SECURITY_MANAGER and dwSupported) = INTERFACE_USES_SECURITY_MANAGER then
           begin
             dwEnabled := dwEnabled or INTERFACE_USES_SECURITY_MANAGER;
           end;
         pOS.SetInterfaceSafetyOptions(IDispatch, INTERFACE_USES_SECURITY_MANAGER, dwEnabled);
      end;
    end;

  hr := FEngine.QueryInterface(IActiveScriptParse, FParser);
  OLECHECK(hr);

  hr := FEngine.SetScriptSite(Self);
  OLECHECK(hr);

  hr := FParser.InitNew();
  OLECHECK(hr);

  for I := 0 to FGlobalObjects.NamedItemCount - 1 do
   begin
    if SameText(FGlobalObjects.NamedItemName[I], 'Basic') then
    FEngine.AddNamedItem(PWideChar(WideString(FGlobalObjects.NamedItemName[I])), SCRIPTITEM_ISVISIBLE  or SCRIPTITEM_GLOBALMEMBERS )
     else
       FEngine.AddNamedItem(PWideChar(WideString(FGlobalObjects.NamedItemName[I])), SCRIPTITEM_ISVISIBLE);
   end;

  FEngine.GetScriptDispatch(nil, Disp);
  FDisp := Disp;

  if Assigned(FOnCreateScriptEngine) then
   FOnCreateScriptEngine(Self);

end;


procedure TpsvActiveScriptSite.CloseScriptEngine;
begin
  FParser := nil;
  if FEngine <> nil then FEngine.Close;
  FEngine := nil;
  FDisp := Unassigned;
end;

function TpsvActiveScriptSite.RunExpression(ACode: WideString): string;
var
  AResult: OleVariant;
  ExcepInfo: TEXCEPINFO;
begin
  CreateScriptEngine(FScriptLanguage);
  if FParser.ParseScriptText(PWideChar(ACode), nil, nil, nil, 0, 0,
    SCRIPTTEXT_ISEXPRESSION, AResult, ExcepInfo) = S_OK
    then
      Result := AResult
        else
          Result := '';
end;


procedure TpsvActiveScriptSite.Execute(ACode: Widestring);
var
  Result: OleVariant;
  ExcepInfo: TEXCEPINFO;
begin
  CreateScriptEngine(FScriptLanguage);
  FParser.ParseScriptText(PWideChar(ACode), nil, nil, nil, 0, 0, 0, Result, ExcepInfo);
  FEngine.SetScriptState(SCRIPTSTATE_CONNECTED);
end;

function TpsvActiveScriptSite.GetDocVersionString(
  out pbstrVersion: WideString): HResult;
begin
  Result := E_NOTIMPL;
end;

function TpsvActiveScriptSite.GetItemInfo(pstrName: LPCOLESTR;
      dwReturnMask: DWORD;
      out ppiunkItem: IUnknown;
      out ppti: ITypeInfo): HResult; stdcall;
begin
  if @ppiunkItem <> nil then Pointer(ppiunkItem) := nil;
  if @ppti <> nil then Pointer(ppti) := nil;
  if (dwReturnMask and SCRIPTINFO_IUNKNOWN) <> 0
    then ppiunkItem := FGlobalObjects.FindNamedItemIntf(pstrName);
  Result := S_OK;
end;

function TpsvActiveScriptSite.GetLCID(out plcid: LongWord): HResult;
begin
  plcid := GetSystemDefaultLCID;
  Result := S_OK;
end;

function TpsvActiveScriptSite.OnEnterScript: HResult;
begin
  result := S_OK;
end;

function TpsvActiveScriptSite.OnLeaveScript: HResult;
begin
  result := S_OK;
end;

function TpsvActiveScriptSite.OnScriptError(
  const pscripterror: IActiveScriptError): HResult;
var
  wCookie   : Dword;
  ExcepInfo : TExcepInfo;
  CharNo    : integer;
  LineNo    : DWORD;
  SourceLineW : WideString;
  SourceLine : string;
  Desc : string;
begin
  Result := S_OK;
  wCookie := 0;
  LineNo  := 0;
  CharNo  := 0;
  if Assigned(pscripterror) then
    begin
      pscripterror.GetExceptionInfo(ExcepInfo);
      Desc := ExcepInfo.bstrDescription;
      pscripterror.GetSourcePosition(wCookie, LineNo, CharNo);
      pscripterror.GetSourceLineText(SourceLineW);
      SourceLine := SourceLineW;
      if Assigned(FOnError) then
        FOnError(Self, LineNo, CharNo, SourceLine, Desc);
    end;
end;

function TpsvActiveScriptSite.OnScriptTerminate(var pvarResult: OleVariant;
  var pexcepinfo: EXCEPINFO): HResult;
begin
  Result := S_OK;
end;

function TpsvActiveScriptSite.OnStateChange(
  ssScriptState: tagSCRIPTSTATE): HResult;
begin
   case ssScriptState of
     SCRIPTSTATE_UNINITIALIZED:;
     SCRIPTSTATE_INITIALIZED:;
     SCRIPTSTATE_STARTED:;
     SCRIPTSTATE_CONNECTED:;
     SCRIPTSTATE_DISCONNECTED:;
     SCRIPTSTATE_CLOSED:;
   end;

   Result := S_OK;

end;


{ TpsvActiveScriptWindow }

function TpsvActiveScriptWindow.EnableModeless(fEnable: BOOL): HResult;
begin
  Result := S_OK;
end;

function TpsvActiveScriptWindow.GetWindow(out phwnd: HWND): HResult;
begin
  if (Owner is TCustomForm) then
   begin
    phwnd := (Owner as TCustomForm).Handle;
    Result := S_OK;
   end
    else
      begin
        phwnd := 0;
        Result := S_FALSE;
      end;
end;


{ TpsvScriptGlobalObjects }

procedure TpsvScriptGlobalObjects.AddNamedIntf(const AName: string; AIntf: IUnknown);
begin
  FNamedList.Add(AName);
  FIntfList.Add(AIntf);
end;

constructor TpsvScriptGlobalObjects.Create;
begin
  inherited Create;
  FNamedList := TStringList.Create;
  FIntfList := TInterfaceList.Create;
end;

destructor TpsvScriptGlobalObjects.Destroy;
begin
  inherited;
  FNamedList.Free;
end;

function TpsvScriptGlobalObjects.FindNamedItemIntf(const AName: string): IUnknown;
var
  I: Integer;
begin
  I := FNamedList.IndexOf(AName);
  if I >= 0 then
    Result := FIntfList[I]
  else
    Result := nil;
end;

function TpsvScriptGlobalObjects.GetNamedItemCount: Integer;
begin
  Result := FNamedList.Count;
end;

function TpsvScriptGlobalObjects.GetNamedItemName(I: Integer): string;
begin
  Result := FNamedList[I];
end;

end.


//Example how to call script procedures at run-time
//Can be used together with all previous examples
unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, psvActiveScript, CustomProcedures, MyProcedures;

type
  TForm1 = class(TForm)
    psvActiveScriptWindow: TpsvActiveScriptWindow;
    Memo1: TMemo;
    Memo2: TMemo;
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
    procedure psvActiveScriptWindowError(Sender: TObject; Line,
      Pos: Integer; ASrc, ADescription: String);
  private
    { Private declarations }
  public
    { Public declarations }
    Username, Flags, _Message, Ping : string;
    Disp : OleVariant;
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
var
 ScriptText : string;
 MyProcedures : TMyProcedures;
 Basic : OleVariant;
begin
  MyProcedures := TMyProcedures.Create;
  psvActiveScriptWindow.AddNamedItem('Basic', Myprocedures);

  //assign values to the variables
   UserName := 'ginsonic';
   Flags := '0';
   _Message := 'Hello';
   Ping := 'Ping';


  //just for demo
  Memo2.Clear;
  Memo2.Lines.Add('Sub Event_UserTalk(Username, Flags, Message, Ping)');
  Memo2.Lines.Add('DisplayString "Hi "&Username&" Hi!"');
  Memo2.Lines.Add('Call DisplayString("My favorite word is "&Blah&"!")');
  Memo2.Lines.Add('End Sub');


  //event occurs, execute script

  //First, set the text of the script
  //can be assigned, loaded from the file, etc....
  ScriptText := Memo2.Text;

  //prepare, but not execute because
  //there is no MAIN procedure
  psvActiveScriptWindow.Execute(ScriptText);

  //get script dispatch interface
  Disp := psvActiveScriptWindow.ScriptInterface;

  //call procedure from the script at run-time
  Disp.Event_UserTalk(UserName, Flags, _Message, Ping);

  Basic := Disp.Basic;

  Basic.DisplayString('Hello from Delphi!');
  Basic.DisplayString(Basic.Blah);
end;

procedure TForm1.psvActiveScriptWindowError(Sender: TObject; Line,
  Pos: Integer; ASrc, ADescription: String);
begin
  ShowMessage(ADescription);
end;

end.






0
 

Author Comment

by:werehamster-
ID: 12171289
Now that component looks more complete.  I've been awake too long.  I'll mess with it when I wake up and give points appropietly.  Thanks for all the help.
0
 

Author Comment

by:werehamster-
ID: 12176893
Ok.  Cool.  I tested it out and it looks like it works great.  Now I can proceed on implementing it in my application.  Thanks for all the help.  :)
0
 

Author Comment

by:werehamster-
ID: 13704979
If you happen to still be around, let me know.  :)
0

Featured Post

Better Security Awareness With Threat Intelligence

See how one of the leading financial services organizations uses Recorded Future as part of a holistic threat intelligence program to promote security awareness and proactively and efficiently identify threats.

Join & Write a Comment

Have you ever had your Delphi form/application just hanging while waiting for data to load? This is the article to read if you want to learn some things about adding threads for data loading in the background. First, I'll setup a general applica…
Introduction I have seen many questions in this Delphi topic area where queries in threads are needed or suggested. I know bumped into a similar need. This article will address some of the concepts when dealing with a multithreaded delphi database…
Here's a very brief overview of the methods PRTG Network Monitor (https://www.paessler.com/prtg) offers for monitoring bandwidth, to help you decide which methods you´d like to investigate in more detail.  The methods are covered in more detail in o…
This demo shows you how to set up the containerized NetScaler CPX with NetScaler Management and Analytics System in a non-routable Mesos/Marathon environment for use with Micro-Services applications.

747 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

13 Experts available now in Live!

Get 1:1 Help Now