formmain.pas

如何使用MS Script OCX控件的例子

(* =======================================================================

 ~~~~~~~~~~~~~~~
  Script Runner
 ~~~~~~~~~~~~~~~

 Version      : 1.00
 Release Date : 24 Nov 1998

 Copyright (C) 1998, Sing Wong
 E-mail : [e-mail]
 (Comments or suggestions are always welcome)

 For more information, please refer to Readme.txt, which distributed
 with this file.

 DISCLAIMER :

 THIS SOFTWARE AND THE ACCOMPANYING FILES ARE PROVIDED "AS IS" WITHOUT
 WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING BUT NOT
 LIMITED TO THE IMPLIED WARRANTIES OF MERCHANTABILITY AND/OR FITNESS
 FOR A PARTICULAR PURPOSE.

========================================================================= *)
unit FormMain;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, Spin, ComCtrls, Buttons;

type
  (* Type of script language *)
  TScriptLang = ( slVB, slJava );

  TfrmMain = class(TForm)
    edScriptFile: TEdit;
    Label1: TLabel;
    Label2: TLabel;
    cboScriptLang: TComboBox;
    Label3: TLabel;
    dlgOpen: TOpenDialog;
    btnOK: TButton;
    btnCancel: TButton;
    sedTimeOut: TSpinEdit;
    Edit1: TEdit;
    btnBrowse: TButton;
    btnAbout: TButton;
    sbMain: TStatusBar;
    procedure FormCreate(Sender: TObject);
    procedure btnOKClick(Sender: TObject);
    procedure btnBrowseClick(Sender: TObject);
    procedure btnCancelClick(Sender: TObject);
    procedure btnAboutClick(Sender: TObject);
    procedure edScriptFileEnter(Sender: TObject);
    procedure btnBrowseEnter(Sender: TObject);
    procedure sedTimeOutEnter(Sender: TObject);
    procedure cboScriptLangEnter(Sender: TObject);
    procedure btnOKEnter(Sender: TObject);
    procedure btnCancelEnter(Sender: TObject);
    procedure btnAboutEnter(Sender: TObject);
  private
    (* Script Engine *)
    vSE : Variant;
  end;

var
  frmMain: TfrmMain;

implementation

{$R *.DFM}

uses
  (* ComObj unit has to be used *)
  ComObj,
  FormStartUp;

const
  (* Program ID of script engine *)
  PID_SCRIPT_ENGINE = 'MSScriptControl.ScriptControl';

  (* Constants for script engine *)
  DEF_MODULE = 'Global';
  SCRIPT_LANG : array [TScriptLang] of string = ( 'VBScript', 'JavaScript' );
  NO_TIME_OUT = -1;

  VERSION = 'v1.00';
  CRLF = Chr(13) + Chr(10);

(*----------------------------------------------------------------------------*)

procedure TfrmMain.FormCreate(Sender: TObject);
begin
  Caption := Application.Title;
  try
    (* Create script engine by CreteOleObject method *)
    vSE := CreateOleObject( PID_SCRIPT_ENGINE );
  except
    on EOleSysError do
      begin
        MessageDlg( 'Unable to initialize the script engine, program terminated',
                    mtError, [mbOK], 0 );
        Application.Terminate;
      end;
  end;
  cboScriptLang.ItemIndex := Integer( slVB );
  with dlgOpen do
    begin
      InitialDir := ExtractFilePath( Application.ExeName );
      with edScriptFile do
        Text := InitialDir + Text;
    end;
end; { FormCreate }

(*----------------------------------------------------------------------------*)

procedure TfrmMain.btnOKClick(Sender: TObject);
var
  sScriptFile, sStartUp : string;
  iTimeOut : Integer;
  sSubName : string;
  iNumArg : Integer;
  bHasReturn : Boolean;
  sReturn : string;
  sArg : string;
  i : Integer;
begin

  sScriptFile := Trim( edScriptFile.Text );
  if Length( sScriptFile ) = 0 then
    begin
      MessageDlg( 'Please input script file name', mtInformation, [mbOK], 0 );
      edScriptFile.SetFocus;
      Exit;
    end;

  with sedTimeOut do
    if Value = 0 then
      iTimeOut := NO_TIME_OUT
    else
      iTimeOut := Value;

  with TStringList.Create do
    try
      (* Load script from specified file *)
      try
        LoadFromFile( sScriptFile );
      except
        on E : Exception do
          begin
            MessageDlg( E.Message, mtError, [mbOK], 0 );
            Exit;
          end;
      end;

      (* Define the script language, can be 'VBScript' or 'JavaScript', for the time being *)
      vSE.Language := SCRIPT_LANG[ TScriptLang(cboScriptLang.ItemIndex) ];

      (* Remove the script from script engine, added last time *)
      vSE.Reset;

      (* Define the maximum run time allowed, -1 stands for unlimited *)
      vSE.TimeOut := iTimeOut;
      try
        (* Add script to script engine *)
        vSE.AddCode( Text );

        (* launch the start up dialog *)
        with TfrmStartUp.Create( Self ) do
          try
            (*
               ==============================================================
                 - Show all available subroutines in script engine, and its
                   details.
                 - Script engine is able to manage more than one modules,
                   however, we just use the default one here (Can be located
                   by key / index 'Global')
                 - Note that the lower bound is not 0 but 1
               ==============================================================
            *)
            for i := 1 to vSE.Modules[ DEF_MODULE ].Procedures.Count do
              with lvStartUp.Items.Add do
                begin
                  (* Get the name of subroutine *)
                  sSubName := vSE.Modules[ DEF_MODULE ].Procedures[ i ].Name;

                  (* Get the total number of argument, if any *)
                  iNumArg := vSE.Modules[ DEF_MODULE ].Procedures[ i ].NumArgs;

                  (* To see if the routine is function or procedure *)
                  bHasReturn := vSE.Modules[ DEF_MODULE ].Procedures[ sSubName ].HasReturnValue;
                  if bHasReturn then
                    Caption := 'Function ' + sSubName
                  else
                    Caption := 'Sub ' + sSubName;

                  (* Add 3 sub items to ListView *)
                  (* The 1st displays the number of argument *)
                  (* The 2nd records the original subroutine name, but not display *)
                  (* The 3rd records the nature of subroutine, also not display *)
                  with SubItems do
                    begin
                      Add( IntToStr(iNumArg) );
                      Add( sSubName );
                      Add( IntToStr(Integer(bHasReturn)) );
                    end;
                end;

            ShowModal;

            with lvStartUp do
              (* If nothing selected, exit *)
              if Selected = nil then
                Exit
              else
                begin
                  (* To see which one selected, and get back its information *)
                  sStartUp := Selected.SubItems[ 1 ];
                  iNumArg := StrToInt( Selected.SubItems[0] );
                  bHasReturn := Boolean( StrToInt(Selected.SubItems[2]) );
                end;

          finally
            Free;  { Start Up Dialog }
          end;

        case iNumArg of
          0 :
            (* Run it, if no argument is requried *)
            sReturn := vSE.Run( sStartUp );
          1 :
            (* Otherwise, get the value of argument before *)
            begin
              sArg := InputBox( Application.Title, 'Argument for ' + sStartUp, '' );
              if Length( sArg ) = 0 then
                Exit;
              sReturn := vSE.Run( sStartUp, sArg );
            end;
        end;

        (* If the selected subroutine was function, display the returned value *)
        if bHasReturn then
          MessageDlg( 'Value returned from function ' + sStartUp + ' = "' + sReturn + '"',
                      mtInformation, [mbOK], 0 );

      except
        on E : EOleException do
          begin
            (*
               =============================================================
                 If exception raised by the running script, show the error
                 information, which provided by script engine
               =============================================================
            *)
            MessageDlg( 'Script Error Found : ' + CRLF +
                        CRLF +
                        'Error Code : ' + IntToStr(vSE.Error.Number) + CRLF +
                        'Description : ' + E.Message + CRLF +
                        'On script Line : ' + IntToStr(vSE.Error.Line) +
                        ', Column : ' + IntToStr(vSE.Error.Column),
                        mtError, [mbOK], 0 );
                        (* Clear the error *)
                        vSE.Error.Clear;
          end;
        on E : Exception do
          MessageDlg( E.Message, mtError, [mbOK], 0 );
      end;

    finally
      Free;  { Script }
    end;

end; { btnOKClick }

(*----------------------------------------------------------------------------*)

procedure TfrmMain.btnBrowseClick(Sender: TObject);
var
  sOldFile : string;
begin
  sOldFile := Trim( edScriptFile.Text );
  with dlgOpen do
    begin
      if FileExists( sOldFile ) then
        FileName := sOldFile;
      if Execute then
        edScriptFile.Text := FileName;
    end;
end;

(*----------------------------------------------------------------------------*)

procedure TfrmMain.btnCancelClick(Sender: TObject);
begin
  Close;
end;

(*----------------------------------------------------------------------------*)

procedure TfrmMain.btnAboutClick(Sender: TObject);
begin
  MessageDlg( Application.Title + ' ' + VERSION + CRLF +
              CRLF +
              'Copyright (C) 1998, Sing Wong' + CRLF +
              'E-mail : [e-mail]',
              mtInformation, [mbOK], 0 );
end;

(*----------------------------------------------------------------------------*)

procedure TfrmMain.edScriptFileEnter(Sender: TObject);
begin
  sbMain.SimpleText := 'Plase input the script file here';
end;

(*----------------------------------------------------------------------------*)

procedure TfrmMain.btnBrowseEnter(Sender: TObject);
begin
  sbMain.SimpleText := 'Click here to launch the open dialog';
end;

(*----------------------------------------------------------------------------*)

procedure TfrmMain.sedTimeOutEnter(Sender: TObject);
begin
  sbMain.SimpleText := 'Specified the maximum run time here, 0 implies unlimited';
end;

(*----------------------------------------------------------------------------*)

procedure TfrmMain.cboScriptLangEnter(Sender: TObject);
begin
  sbMain.SimpleText := 'Plase select the script language here';
end;

(*----------------------------------------------------------------------------*)

procedure TfrmMain.btnOKEnter(Sender: TObject);
begin
  sbMain.SimpleText := 'Click here to run script';
end;

(*----------------------------------------------------------------------------*)

procedure TfrmMain.btnCancelEnter(Sender: TObject);
begin
  sbMain.SimpleText := 'Click here to quit the Script Runner';
end;

(*----------------------------------------------------------------------------*)

procedure TfrmMain.btnAboutEnter(Sender: TObject);
begin
  sbMain.SimpleText := 'Click here to see information of Script Runner';
end;

end.