home *** CD-ROM | disk | FTP | other *** search
/ Chip 1999 March / Chip_1999-03_cd.bin / zkuste / delphi / INFO / DI9802TS.ZIP / ScriptDemo.pas < prev    next >
Pascal/Delphi Source File  |  1997-08-27  |  7KB  |  244 lines
  1. { Tom Stickle - tstix@dancris.com }
  2. { Simple ActiveX Scripting demo }
  3. unit ScriptDemo;
  4.  
  5. interface
  6.  
  7. uses
  8.   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  9.   StdCtrls, ScriptSite, Activscp, ActiveX, ComObj, Buttons, Menus, ExtCtrls,
  10.   About;
  11.  
  12. type
  13.   TScriptingDemo = class(TForm)
  14.     tmEditor: TMemo;
  15.     dlgOpen: TOpenDialog;
  16.     dlgSave: TSaveDialog;
  17.     Panel1: TPanel;
  18.     btnFire: TButton;
  19.     teEventName: TEdit;
  20.     MainMenu1: TMainMenu;
  21.     File1: TMenuItem;
  22.     Open1: TMenuItem;
  23.     Save1: TMenuItem;
  24.     N1: TMenuItem;
  25.     Exit1: TMenuItem;
  26.     Language1: TMenuItem;
  27.     tmVBScript: TMenuItem;
  28.     tmJScript: TMenuItem;
  29.     Help1: TMenuItem;
  30.     About1: TMenuItem;
  31.     procedure tmOpenClick(Sender: TObject);
  32.     procedure tmSaveClick(Sender: TObject);
  33.     procedure btnFireClick(Sender: TObject);
  34.     procedure tmVBScriptClick(Sender: TObject);
  35.     procedure About1Click(Sender: TObject);
  36.   private
  37.     { Private declarations }
  38.     ActiveScript :      IActiveScript;
  39.     ActiveScriptParse : IActiveScriptParse;
  40.     ActiveScriptSite :  IActiveScriptSite;
  41.     function  GetScriptFilter: String;
  42.     function  InitEngine : Boolean;  safecall;
  43.     procedure FireMethod(const EventName : WideString); safecall;
  44.     function  ParseScript(const ScriptText : WideString): Boolean; safecall;
  45.     procedure StopEngine; safecall;
  46.   public
  47.     { Public declarations }
  48.   end;
  49.  
  50. var
  51.   ScriptingDemo: TScriptingDemo;
  52.  
  53. implementation
  54.  
  55. {$R *.DFM}
  56.  
  57. { Opens a script file }
  58. procedure TScriptingDemo.tmOpenClick(Sender: TObject);
  59. begin
  60.   tmEditor.Lines.Clear;
  61.   dlgOpen.Filter := GetScriptFilter;
  62.   if dlgOpen.Execute then
  63.     tmEditor.Lines.LoadFromFile(dlgOpen.FileName);
  64. end;
  65.  
  66. { Saves a script file }
  67. procedure TScriptingDemo.tmSaveClick(Sender: TObject);
  68. begin
  69.   dlgSave.Filter := GetScriptFilter;
  70.   if dlgSave.Execute then
  71.     tmEditor.Lines.SaveToFile(dlgSave.FileName);
  72. end;
  73.  
  74. { Returns File Filter }
  75. function TScriptingDemo.GetScriptFilter: String;
  76. begin
  77.   if tmVBScript.Checked then
  78.     Result := 'VBScript|*.bas|JScript|*.js'
  79.   else
  80.     Result := 'JScript|*.js|VBScript|*.bas';
  81. end;
  82.  
  83.  
  84. procedure TScriptingDemo.tmVBScriptClick(Sender: TObject);
  85. begin
  86.   (Sender as TMenuItem).Checked := True;
  87. end;
  88.  
  89.  
  90. { This Initializes Script Engine and declares internal objects }
  91. function TScriptingDemo.InitEngine : Boolean;
  92. var
  93.   Flags : Word;
  94.   CatID : TGuid;
  95. begin
  96.   Result := False;
  97.  
  98.   { Retrieve activeScript interface via IUnknown }
  99.   { By changing the CatID, we can easily change scripting engines from VBScript
  100.     to any other installed scripting engine, ie. JavaScript etc... }
  101.   if tmVBScript.Checked then
  102.     CatID := CatID_VBScript
  103.   else
  104.     CatID := CatID_JScript;
  105.  
  106.   ActiveScript := IActiveScript(CreateComObject(CatID));
  107.  
  108.   { Get Interface pointer for IActiveScriptParse Interface }
  109.   if (ActiveScript.QueryInterface(IID_IActiveScriptParse,
  110.       ActiveScriptParse) <> S_OK) then
  111.     Exit;
  112.  
  113.   { COM Host Object Implementation  }
  114.   ActiveScriptSite := IActiveScriptSite(TActiveScriptSite.Create);
  115.  
  116.   { Register Site Object with the ActiveScript Engine }
  117.   if ActiveScript.SetScriptSite(ActiveScriptSite) <> S_OK then
  118.     Exit;
  119.  
  120.   { initialize the engine }
  121.   if (ActiveScriptParse.InitNew <> S_OK) then
  122.     exit;
  123.  
  124.   Flags  := SCRIPTITEM_ISVISIBLE;
  125.  
  126.   { Add our custom COM Object to script engine }
  127.   if (ActiveScript.AddNamedItem( 'MyObj', Flags ) <> S_OK) then
  128.     exit;
  129.  
  130.   { Now fire up the scripting engine }
  131.   if ActiveScript.SetScriptState(SCRIPTSTATE_CONNECTED) <> S_OK then
  132.     Exit;
  133.  
  134.   {  If we made it this far then we have succesfully initialized the engine! }
  135.   Result := true;
  136. end;
  137.  
  138.  
  139. { This parses the Script }
  140. function TScriptingDemo.ParseScript(const ScriptText : WideString) : Boolean;
  141. var
  142.   Ei:            TExcepInfo;
  143.   Flags:         DWord;
  144.   VarOut:        OleVariant;
  145. begin
  146.  
  147.   Flags := SCRIPTTEXT_NULL;
  148.  
  149.   Result := (activeScriptParse.ParseScriptText(ScriptText, nil, nil, nil,
  150.          0, 0, Flags, VarOut, Ei) = S_OK);
  151.  
  152. end;
  153.  
  154.  
  155. { This calls the Main Subroutine/Function in the Script }
  156. procedure TScriptingDemo.FireMethod(const EventName : WideString);
  157. var
  158.   Disp:               Integer;
  159.   DispParams:         TDispParams;
  160.   Ei:                 TExcepInfo;
  161.   InvKind:            Integer;
  162.   ReturnVal:          POleVariant;
  163.   ScriptDispatch :    IDispatch;
  164. begin
  165.  
  166.   if ActiveScript.GetScriptDispatch(nil, ScriptDispatch) <> S_OK then
  167.     Exit;
  168.  
  169.   { Initialize dispatch id }
  170.   Disp    := -1;
  171.  
  172.   {  Get a dispatch id number that corresponds the eventName name }
  173.   ScriptDispatch.getIDsOfNames(GUID_NULL, @eventName, 1, LOCALE_USER_DEFAULT, @disp);
  174.  
  175.   { See if anything was found for the EventName - Spelling Error will fail! }
  176.   if disp = -1 then begin
  177.     ShowMessage(Format('The method %s was not found in the script...', [EventName]));
  178.     exit;
  179.   end;
  180.  
  181.   { Set the type of invocation to method }
  182.   InvKind := DISPATCH_METHOD;
  183.  
  184.   { This structure can contain up to 32 arguments to pass in }
  185.   ReturnVal := nil;
  186.   DispParams.rgvarg := nil;
  187.   DispParams.rgdispidNamedArgs := nil;
  188.   DispParams.cArgs := 0;
  189.   DispParams.cNamedArgs := 0;
  190.  
  191.   { Fire the Event via ID Binding }
  192.   ScriptDispatch.Invoke(Disp, GUID_NULL, 0, InvKind, DispParams,
  193.     ReturnVal, @ei, nil);
  194. end;
  195.  
  196.  
  197.  
  198. { Resets Engine Clearing the Script and all Objects }
  199. procedure TScriptingDemo.StopEngine;
  200. begin
  201.   ActiveScript.SetScriptState(SCRIPTSTATE_UNINITIALIZED);
  202. end;
  203.  
  204.  
  205. { Parse Script and Fire the "OnEvent" Sub/Function }
  206. procedure TScriptingDemo.btnFireClick(Sender: TObject);
  207. begin
  208.   try
  209.     InitEngine;
  210.   except
  211.     on Exception do
  212.       { Present a real error message }
  213.       Raise Exception.Create('Unable to initialize scripting engine.');
  214.   end;
  215.  
  216.   { Once the engine is initialized, errors will be reported to the user
  217.     either by our Scripting Site object or in the FireMethod routine.
  218.     We can then just catch them here to prevent the application from halting. }
  219.   try
  220.     ParseScript(tmEditor.Text);
  221.     FireMethod(teEventName.Text);
  222.   except
  223.     on Exception do  { Error Message displayed in IActiveScriptSite }
  224.   end;
  225.  
  226.   StopEngine;
  227. end;
  228.  
  229.  
  230. procedure TScriptingDemo.About1Click(Sender: TObject);
  231. var
  232.   AboutBox : TAboutBox;
  233. begin
  234.   AboutBox := TAboutBox.Create(self);
  235.   try
  236.     AboutBox.ShowModal;
  237.   finally
  238.     AboutBox.Free;
  239.   end;
  240. end;
  241.  
  242.  
  243. end.
  244.