unit uAutoObject;

{$WARN SYMBOL_PLATFORM OFF}

interface

uses
  ComObj, ActiveX, ExposingObjects_TLB, StdVcl;

type
  TExposingObjectsDemo = class(TAutoObject, IExposingObjectsDemo)
  protected
    procedure SetFormColor(Color: OLE_COLOR); stdcall;
    procedure SetFormCaption(Caption: OleVariant); stdcall;
    function Get_Age: SYSINT; safecall;
    function Get_Name: OleVariant; safecall;
    procedure Set_Age(Value: SYSINT); safecall;
    procedure Set_Name(Value: OleVariant); safecall;
  end;

implementation

uses ComServ;

procedure TExposingObjectsDemo.SetFormColor(Color: OLE_COLOR);
begin

end;

procedure TExposingObjectsDemo.SetFormCaption(Caption: OleVariant);
begin

end;

function TExposingObjectsDemo.Get_Age: SYSINT;
begin

end;

function TExposingObjectsDemo.Get_Name: OleVariant;
begin

end;

procedure TExposingObjectsDemo.Set_Age(Value: SYSINT);
begin

end;

procedure TExposingObjectsDemo.Set_Name(Value: OleVariant);
begin

end;

initialization
  TAutoObjectFactory.Create(ComServer, TExposingObjectsDemo, Class_ExposingObjectsDemo,
    ciMultiInstance, tmApartment);
end.

Function Hello(Color)
  MsgBox "こんにちは " & DemoObject.Name & " さん" & vbCrLf &_
         "貴方は " & DemoObject.Age & " 歳ですね"
  DemoObject.SetFormColor Color
  DemoObject.SetFormCaption InputBox("新しいタイトルの入力")
End Function

program Project1;

uses
  Forms,
  Unit1 in 'Unit1.pas' {Form1};

{$R ExposingObjects.tlb}

{$R *.res}

begin
  Application.Initialize;
  Application.MainFormOnTaskbar := True;
  Application.CreateForm(TForm1, Form1);
  Application.Run;
end.

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    LabeledEdit1: TLabeledEdit;
    LabeledEdit2: TLabeledEdit;
    ButtonColor1: TButtonColor;
    Button1: TButton;
    Panel1: TPanel;
    procedure Button1Click(Sender: TObject);
    procedure FormShow(Sender: TObject);
  private
    { Private 宣言 }
    VBScript    : TScriptControl;
    FAutoObject : TExposingObjectsDemo;
  public
    { Public 宣言 }
    function GetNameValue : String;
    procedure SetNameValue(AName : String);
    function GetAgeValue : Integer;
    procedure SetAgeValue(AgeValue : Integer);
    procedure ChangeFormColor(AColor : TColor);
    procedure ChangeFormCaption(ACaption : String);
  end;

var
  Form1: TForm1;

implementation

uses ActiveX;

{$R *.dfm}

//=============================================================================
//  TScriptControlの生成とコードの生成
//=============================================================================
procedure TForm1.FormShow(Sender: TObject);
var
  SL : TStringList;
begin
  LabeledEdit1.Text := '日本　太郎';
  LabeledEdit2.Text := '30';

  //VBScriptのオブジェクトを生成
  VBScript := TScriptControl.Create(Self);
  VBScript.Language := 'VBScript';
  VBScript.SitehWnd := Self.Handle;

  //TExposingObjectsDemoのインスタンスを生成し，DemoObjectという名前で追加
  FAutoObject := TExposingObjectsDemo.Create;
  VBScript.AddObject('DemoObject', FAutoObject, False);

  //コードを格納するTStringList生成
  SL := TStringList.Create;
  try
    //コードを読込む
    SL.LoadFromFile(ExtractFilePath(Application.ExeName) + 'HelloTest.vbs');
    //スクリプトにコードを追加
    VBScript.AddCode(SL.Text);
  finally
    FreeAndNil(SL);
  end;
end;

//=============================================================================
//  引数を与えてVBScriptを実行
//  引数はバリアント型の配列で与える
//
//  PSafeArrayの使用には，usesにActiveXが必要
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  Params : PSafeArray;
  V      : Variant;
begin
  //VBScriptの関数に渡す値をセット
  V      := VarArrayCreate([0, 0], varVariant);
  V[0]   := ButtonColor1.SymbolColor;
  Params := PSafeArray(TVarData(V).VArray);

  //VBSのコード内のHelloという関数を実行
  //引数はParamsで渡す
  VBScript.Run('Hello', Params);
end;

//=============================================================================
//  Panelの色を変更するメソッド
//=============================================================================
procedure TForm1.ChangeFormColor(AColor: TColor);
begin
  Panel1.ParentBackground := False;
  Panel1.Color := AColor;
end;

//=============================================================================
//  フォームのキャプション(タイトル)のテキストを変更するメソッド
//=============================================================================
procedure TForm1.ChangeFormCaption(ACaption: String);
begin
  Self.Caption := ACaption;
end;

//=============================================================================
//  VBScript内で名前を取得するコードを実行すると実行されるメソッド
//  VBScriptの変数に値を返す
//=============================================================================
function TForm1.GetNameValue: String;
begin
  Result := LabeledEdit1.Text;
end;

//=============================================================================
//  VBScript内で名前をセットすると実行されるメソッド
//  本サンプルでは使用していない
//=============================================================================
procedure TForm1.SetNameValue(AName: String);
begin
  LabeledEdit1.Text := AName;
end;

//=============================================================================
//  VBScript内で年齢を取得するコードを実行すると実行されるメソッド
//  VBScriptの変数に値を返す
//=============================================================================
function TForm1.GetAgeValue: Integer;
begin
  Result := StrToIntDef(LabeledEdit2.Text, 0);
end;

//=============================================================================
//  VBScript内で年齢をセットすると実行されるメソッド
//  本サンプルでは使用していない
//=============================================================================
procedure TForm1.SetAgeValue(AgeValue: Integer);
begin
  LabeledEdit2.Text := IntToStr(AgeValue);
end;

end.

unit uAutoObject;

{$WARN SYMBOL_PLATFORM OFF}

interface

uses
  ComObj, ActiveX, ExposingObjects_TLB, StdVcl;

type
  TExposingObjectsDemo = class(TAutoObject, IExposingObjectsDemo)
  protected
    procedure SetFormColor(Color: OLE_COLOR); stdcall;
    procedure SetFormCaption(Caption: OleVariant); stdcall;
    function Get_Age: SYSINT; safecall;
    function Get_Name: OleVariant; safecall;
    procedure Set_Age(Value: SYSINT); safecall;
    procedure Set_Name(Value: OleVariant); safecall;
  end;

implementation

uses ComServ, Unit1;

//-----------------------------------------------------------------------------
//  VBScript内でSetFormColorメソッドを実行したら，Form1のChangeFormColor
//  メソッド実行する
//-----------------------------------------------------------------------------
procedure TExposingObjectsDemo.SetFormColor(Color: OLE_COLOR);
begin
  Form1.ChangeFormColor(Color);
end;

//-----------------------------------------------------------------------------
//  VBScript内でSetFormCaptionメソッドを実行したら，Form1のChangeFormCaption
//  メソッド実行する
//-----------------------------------------------------------------------------
procedure TExposingObjectsDemo.SetFormCaption(Caption: OleVariant);
begin
  Form1.ChangeFormCaption(Caption);
end;

//-----------------------------------------------------------------------------
//  VBScript内でAgeの値を取得するコードを実行したら，Form1のGetAgeValueメソッド
//  実行して値を取得する
//-----------------------------------------------------------------------------
function TExposingObjectsDemo.Get_Age: SYSINT;
begin
  Result := Form1.GetAgeValue;
end;

//-----------------------------------------------------------------------------
//  VBScript内でNameの値を取得するコードを実行したら，Form1のGetNameValueメソッ
//  ド実行して値を取得する
//-----------------------------------------------------------------------------
function TExposingObjectsDemo.Get_Name: OleVariant;
begin
  Result := Form1.GetNameValue;
end;

//-----------------------------------------------------------------------------
//  VBScript内でAgeの値をセットしたら，Form1のSetAgetValueメソッドを実行する
//  タイプライブラリではAgeの設定メソッドはSet_Age
//  本サンプルでは使用していない
//-----------------------------------------------------------------------------
procedure TExposingObjectsDemo.Set_Age(Value: SYSINT);
begin
  Form1.SetAgeValue(Value);
end;

//-----------------------------------------------------------------------------
//  VBScript内でNameの値をセットしたら，Form1のSetNameValueメソッドを実行する
//  タイプライブラリではNameの設定メソッドはSet_Name
//  本サンプルでは使用していない
//-----------------------------------------------------------------------------
procedure TExposingObjectsDemo.Set_Name(Value: OleVariant);
begin
  Form1.SetNameValue(Value);
end;

//-----------------------------------------------------------------------------
initialization
  TAutoObjectFactory.Create(ComServer, TExposingObjectsDemo, Class_ExposingObjectsDemo,
    ciMultiInstance, tmApartment);
end.