Self.Caption = "Сегодня: " +DTOC(DATE))
SCAN
   Edit1.Text = STR(RECNO())
ENDSCAN

unit VclProxyDisp;

interface

uses Classes, TypInfo, ComObj, Variants, ActiveX, SysUtils, Controls, Windows,
     Contnrs, Forms, Graphics, dialogs, vfp7serv_TLB;

type
     TVCLProxy = class;
     TVFPConnector = class;

     IEnumVariant = interface(IUnknown)
     ['{00020404-0000-0000-C000-000000000046}']
     function Next(celt: LongWord; var rgvar: OleVariant;
       pceltFetched: PLongWord): HResult; stdcall;
     function Skip(celt: LongWord): HResult; stdcall;
     function Reset: HResult; stdcall;
     function Clone(out Enum: IEnumVariant): HResult; stdcall;
   end;  


   IQueryPersistent = interface
  ['{26F5B6E1-9DA5-11D3-BCAD-00902759A497}']
      function GetPersistent: TPersistent;
   end;

  TDispIDsArray = array[ 0 .. 0 ] of TDISPID;
  PDispIDsArray = ^TDispIDsArray;
  TVariantList = array [ 0 .. 0 ] of OleVariant;

  TTypeCompStub = class(TinterfacedObject, iTypeComp)
     private
     FOwner: TVCLProxy;
     public
     constructor Create(AOwner: TVCLProxy);
     function Bind(szName: POleStr; lHashVal: Longint; wflags: Word;
        out tinfo: ITypeInfo; out desckind: TDescKind;
        out bindptr: TBindPtr): HResult; stdcall;
     function BindType(szName: POleStr; lHashVal: Longint;
        out tinfo: ITypeInfo; out tcomp: ITypeComp): HResult;stdcall;
  end;

  TNamedItemList = class(TObjectList)
    private
    FConnector: TVFPConnector;
  public
    constructor Create(Connector: TVFPConnector);
    procedure AddItem(const Name: string; Item: IDispatch);
    function GetItemIDispatch(const Name: string): IDispatch;
    function FindItem(Item: string): IDispatch;
    procedure Clear; override;
  end;

  TNamedItem = class
  protected
    FTypeInfo: ITypeInfo;
    FDispatch: IDispatch;
    FName: string;
  end;

  TTypeinfoPlug = class(TinterfacedObject, iTypeinfo)
    private
      FClassNameStr: WideString;
      FOwner: TVCLProxy;
    public
    function GetTypeAttr(out ptypeattr: PTypeAttr): HResult; stdcall;
    function GetTypeComp(out tcomp: ITypeComp): HResult; stdcall;
    function GetFuncDesc(index: Integer; out pfuncdesc: PFuncDesc): HResult;
      stdcall;
    function GetVarDesc(index: Integer; out pvardesc: PVarDesc): HResult;
      stdcall;
    function GetNames(memid: TMemberID; rgbstrNames: PBStrList;
      cMaxNames: Integer; out cNames: Integer): HResult; stdcall;
    function GetRefTypeOfImplType(index: Integer; out reftype: HRefType): HResult;
      stdcall;
    function GetImplTypeFlags(index: Integer; out impltypeflags: Integer): HResult;
      stdcall;
    function GetIDsOfNames(rgpszNames: POleStrList; cNames: Integer;
      rgmemid: PMemberIDList): HResult; stdcall;
    function Invoke(pvInstance: Pointer; memid: TMemberID; flags: Word;
      var dispParams: TDispParams; varResult: PVariant;
      excepInfo: PExcepInfo; argErr: PInteger): HResult; stdcall;
    function GetDocumentation(memid: TMemberID; pbstrName: PWideString;
      pbstrDocString: PWideString; pdwHelpContext: PLongint;
      pbstrHelpFile: PWideString): HResult; stdcall;
    function GetDllEntry(memid: TMemberID; invkind: TInvokeKind;
      bstrDllName, bstrName: PWideString; wOrdinal: PWord): HResult;
      stdcall;
    function GetRefTypeInfo(reftype: HRefType; out tinfo: ITypeInfo): HResult;
      stdcall;
    function AddressOfMember(memid: TMemberID; invkind: TInvokeKind;
      out ppv: Pointer): HResult; stdcall;
    function CreateInstance(const unkOuter: IUnknown; const iid: TIID;
      out vObj): HResult; stdcall;
    function GetMops(memid: TMemberID; out bstrMops: WideString): HResult;
      stdcall;
    function GetContainingTypeLib(out tlib: ITypeLib; out pindex: Integer): HResult;
      stdcall;
    procedure ReleaseTypeAttr(ptypeattr: PTypeAttr); stdcall;
    procedure ReleaseFuncDesc(pfuncdesc: PFuncDesc); stdcall;
    procedure ReleaseVarDesc(pvardesc: PVarDesc); stdcall;
    constructor Create(AOwner: TVCLProxy; ClassNameStr: WideString);
  end;

  TVFPConnector = class(TComponent)
     private
       FForm: TCustomForm;
       FNamedItems: TNamedItemList;
       FCode: TStringList;
      procedure RegisterClass(AName: string; PC: TPersistent);
    procedure SetCode(const Value: TStringList);
     public
       FVFP: Ivfpoleserver;
      constructor Create(AOwner: TComponent); override;
      destructor Destroy; override;
      function GetProxy(P: TPersistent): OleVariant;
      function Execute: OleVariant;
      procedure SetForm(frm: TCustomForm);
      procedure FreeItems;
      property NamedItems: TNamedItemList read FNamedItems;
     published
      property Code: TStringList read FCode write SetCode;
     end;

   TVCLEnum = class(TInterfacedObject, IEnumVariant)
   private
     FEnumPosition: Integer;
     FOwner: TPersistent;
     FScriptControl: TVFPConnector;
     { IEnumVariant }
     function Next(celt: LongWord; var rgvar: OleVariant;
       pceltFetched: PLongWord): HResult; stdcall;
     function Skip(celt: LongWord): HResult; stdcall;
     function Reset: HResult; stdcall;
     function Clone(out Enum: IEnumVariant): HResult; stdcall;
   public
     constructor Create(AOwner: TPersistent;
       AScriptControl: TVFPConnector);
   end;


   TVCLProxy = class(TInterfacedObject, IDispatch, IQueryPersistent)
   private
     FOwner: TPersistent;
     FScriptControl: TVFPConnector;
     procedure DoCreateControl(AName, AClassName: WideString;
       WithEvents: Boolean);
     function SetVCLProperty(PropInfo: PPropInfo;
       Argument: TVariantArg): HRESULT;
     function GetVCLProperty(PropInfo: PPropInfo; dps: TDispParams;
       PDispIds: PDispIdList; var Value: OleVariant): HRESULT;
     { IDispatch }
     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;
     { IQueryPersistent }
     function GetPersistent: TPersistent;
   protected
     function DoInvoke (DispID: Integer; const IID: TGUID;
       LocaleID: Integer; Flags: Word; var dps : TDispParams;
       pDispIds : PDispIdList; VarResult, ExcepInfo,
       ArgErr: Pointer): HResult; virtual;
   public
     constructor Create(AOwner: TPersistent;
       ScriptControl: TVFPConnector);
     destructor Destroy; override;
   end;

  PNamesArray = ^TNamesArray;
  TNamesArray = array[ 0 .. 0 ] of PWideChar;

const
  DISPID_CONTROLS =  1 ;
  DISPID_COUNT =  2 ;
  DISPID_ADD =  3 ;
  DISPID_HASPROPERTY =  4 ;


procedure Register;

implementation


//uses ActiveX;

procedure Register;
begin
//  RegisterComponents('Stat', [TFVPConnector]);
end;

function TVCLProxy.GetIDsOfNames(const  IID: TGUID; Names: Pointer;
   NameCount, LocaleID: Integer; DispIDs: Pointer): HResult;
 var
   S: String;
   Info: PPropInfo;
 begin
   Result := S_OK;
   S := PNamesArray(Names)[ 0 ];
   Info := GetPropInfo(FOwner.ClassInfo, S);
   if Assigned(Info) then begin
     PDispIdsArray(DispIds)[ 0 ] := Integer(Info);
   end
 else
   if CompareText(S, 'CONTROLS') =  0  then begin
     if (FOwner is TWinControl) then
       PDispIdsArray(DispIds)[ 0 ] := DISPID_CONTROLS
     else
       Result := DISP_E_UNKNOWNNAME;
   end
   else 
  if CompareText(S, 'COUNT') =  0  then begin
     if (FOwner is TCollection) or (FOwner is TStrings)
        or (FOwner is TWinControl) then
       PDispIdsArray(DispIds)[ 0 ] := DISPID_COUNT
     else
       Result := DISP_E_UNKNOWNNAME;
   end  
 else
   if CompareText(S, 'ADD') =  0  then begin
     Result := S_OK;
     if (FOwner is TCollection) or (FOwner is TStrings) or
        (FOwner is TWinControl) then
       PDispIdsArray(DispIds)[ 0 ] := DISPID_ADD
     else
       Result := DISP_E_UNKNOWNNAME;
   end
 else

  if CompareText(S, 'HASPROPERTY') =  0  then
     PDispIdsArray(DispIds)[ 0 ] := DISPID_HASPROPERTY
   else
     Result := DISP_E_UNKNOWNNAME;
 end;  

function TVCLProxy.DoInvoke(DispID: Integer; const IID: TGUID;
   LocaleID: Integer; Flags: Word; var dps: TDispParams;
   pDispIds: PDispIdList; VarResult, ExcepInfo, ArgErr: Pointer
   ): HResult;
 var
   S: String;
   Put: Boolean;
   I: Integer;
   P: TPersistent;
   B: Boolean;
   OutValue: OleVariant;  
   v: tagVariant;
procedure CheckArgCount(args: LongInt; ar: array of integer; b_excp: boolean);
  var Err: Boolean;
  i, nc, np: integer;
  label l_err;
begin
  if args <=  0  then goto l_err;
     nc:=Length(ar);
  for i:= 1  to nc do begin
    if args < ar[i- 1 ] then goto l_err;
  end;
  Exit;
l_err:
  if b_excp then raise Exception.Create('Íåâåðíîå êîëè÷åñòâî ïàðàìåòðîâ !');
end;

function _ValidType(n_arg: integer; chk_type: integer; cond: boolean): boolean;
var ov: OleVariant;
    ie: Integer;
begin
  Result:=dps.rgvarg^[n_arg].vt = chk_type;
  if not Result and cond then raise Exception.Create('Íåñîîòâåòñâèå òèïà !');
end;

function _IntValue(cn: Integer): integer;
begin
  Result:=dps.rgvarg^[cn].intVal;
end;

begin
   Result := S_OK;
   case DispId of
   DISPID_CONTROLS:
         begin
         with FOwner as TWinControl do
         begin
           CheckArgCount(dps.cArgs, [ 1 ], TRUE);
           P := NIL;
           if _ValidType( 0 , VT_BSTR, FALSE) then begin
             S := dps.rgvarg^[pDispIds^[ 0 ]].bstrVal;
             for I :=  0  to Pred(ControlCount) do
               if CompareText(S, Controls[I].Name) =  0  then begin
                 P := Controls[I];
                 Break;
               end;
           end else begin
             I := _IntValue( 0 );
             P := Controls[I];
           end;
           if not Assigned(P) then
             raise Exception.Create('Íåâîçìîæíî íàéòè êîìïîíåíò '+S+'!');
           OleVariant(VarResult^) := FScriptControl.GetProxy(P);
         end;
       end;
   DISPID_COUNT:
        begin
         CheckArgCount(dps.cArgs, [ 0 ], TRUE);
         if FOwner is TWinControl then
           OleVariant(VarResult^) := TWinControl(FOwner).ControlCount
         else
         if FOwner is TCollection then
           OleVariant(VarResult^) := TCollection(FOwner).Count
         else
         if FOwner is TStrings then
           OleVariant(VarResult^) := TStrings(FOwner).Count;
       end;  
   DISPID_ADD:
         begin
         if FOwner is TWinControl then begin
           CheckArgCount(dps.cArgs, [ 2 , 3 ], TRUE);
           _ValidType( 0 , VT_BSTR, TRUE);
           _ValidType( 1 , VT_BSTR, TRUE);
           if (dps.cArgs =  3 ) and _ValidType( 2 , VT_BOOL, TRUE) then
             B := dps.rgvarg^[pDispIds^[ 0 ]].vbool
           else
             B := FALSE;
           DoCreateControl(dps.rgvarg^[pDispIds^[ 0 ]].bstrVal,
             dps.rgvarg^[pDispIds^[ 1 ]].bstrVal, B);
         end
         else
         if FOwner is TCollection then begin
           P := TCollection(FOwner).Add;
           OleVariant(varResult^) := FScriptControl.GetProxy(P);
         end
         else
         if FOwner is TStrings then begin
           CheckArgCount(dps.cArgs, [ 1 , 2 ], TRUE);
           _ValidType( 0 , VT_BSTR, TRUE);
           if dps.cArgs =  2  then
             I := _IntValue( 1 )
           else
             I := TStrings(FOwner).Count;
           TStrings(FOwner).Insert(I,
             dps.rgvarg^[pDispIds^[ 0 ]].bstrVal);
         end;
       end;

   DISPID_HASPROPERTY:
       begin
         CheckArgCount(dps.cArgs, [ 1 ], TRUE);
         _ValidType( 0 , VT_BSTR, TRUE);
         S := dps.rgvarg^[pDispIds^[ 0 ]].bstrVal;
         OleVariant(varResult^) :=
           Assigned(GetPropInfo(FOwner.ClassInfo, S));
       end;  

    DISPID_NEWENUM: begin
         OleVariant(VarResult^) := TVCLEnum.Create(FOwner,
           FScriptControl) as IEnumVariant;
       end;


else
     Put := (Flags and DISPATCH_PROPERTYPUT) <>  0 ;
     if Put then begin
       CheckArgCount(dps.cArgs, [ 1 ], TRUE);
       v:=dps.rgvarg^[{pDispIds^[ 0 ]} 0 ];
       Result := SetVCLProperty(PPropInfo(DispId),
         dps.rgvarg^[ 0 {pDispIds^[ 0 ]}]) // dps.rgvarg^[pDispIds^[ 0 ]] -  192 ; 240 ; 227 ; 243 ; 229 ; 236 ; 237 ; 242 ;  226 ; 224 ; 240 ; 232 ; 224 ; 237 ; 242 ; 237 ; 238 ; 227 ; 238 ;  242 ; 232 ; 239 ; 224 ;
     end
     else
     begin
       if DispId =  0  then begin
         OleVariant(VarResult^) := Self as IDispatch;
         Exit;
       end;
       Result := GetVCLProperty(PPropInfo(DispId),
         dps, pDispIds, OutValue);
       if Result = S_OK then
         OleVariant(VarResult^) := OutValue;
     end;
   end;
 end;

procedure TVCLProxy.DoCreateControl(AName, AClassName: WideString;
   WithEvents: Boolean);

   procedure SetHandler(Control: TPersistent; Owner: TObject;
     Name: String);
   var
     Method: TMethod;
     PropInfo: PPropInfo;
   begin
     PropInfo := GetPropInfo(Control.ClassInfo, Name);
     if Assigned(PropInfo) then begin
       Method.Code := FScriptControl.MethodAddress(Name + 'Handler');
       if Assigned(Method.Code) then begin
         Method.Data := FScriptControl;
         SetMethodProp(Control, PropInfo, Method);
       end;
     end;
    end;


var
   ThisClass: TControlClass;
   C: TComponent;
   NewOwner: TCustomForm;
 begin
   if not (FOwner is TCustomForm) then
     NewOwner := GetParentForm(FOwner as TControl)
   else
     NewOwner := FOwner as TCustomForm;
   ThisClass := TControlClass(GetClass(AClassName));
   C := ThisClass.Create(NewOwner);
   C.Name := AName;
   if C is TControl then
     TControl(C).Parent := FOwner as TWinControl;
   if WithEvents then begin
     SetHandler(C, NewOwner, 'OnClick');
     SetHandler(C, NewOwner, 'OnChange');
     SetHandler(C, NewOwner, 'OnEnter');
     SetHandler(C, NewOwner, 'OnExit');
     SetHandler(C, NewOwner, 'OnTimer');
   end;
   FScriptControl.RegisterClass(AName, C);
 end;


////*********************************************
function TVCLProxy.GetVCLProperty(PropInfo: PPropInfo; dps: TDispParams;
       PDispIds: PDispIdList; var Value: OleVariant): HRESULT;

 var
   I, J, K: Integer;
   S: String;
   P, P1: TPersistent;
   Data: PTypeData;
   DT: TDateTime;
   TypeInfo: PTypeInfo;

function ValidType(n_arg: tagVARIANT; chk_type: integer; cond: boolean): boolean;
var ov: OleVariant;
    ie: Integer;
begin
  Result:=DispGetParam(dps, n_arg.intVal, chk_type, ov, ie) = S_OK;
end;

function IntValue(cn: tagVARIANT): integer;
begin
  Result:=dps.rgvarg^[cn.intVal].intVal;
end;

 begin
   Result := S_OK;
   case PropInfo^.PropType^.Kind  of
     tkString, tkLString, tkWChar, tkWString:
       Value := GetStrProp(FOwner, PropInfo);
    tkChar, tkInteger:
       Value := GetOrdProp(FOwner, PropInfo);
    tkEnumeration:
       begin
         if CompareText(PropInfo^.PropType^.Name, 'BOOLEAN') =  0  then
           Value := Boolean(GetOrdProp(FOwner, PropInfo))
         else begin
           I := GetOrdProp(FOwner, PropInfo);
           Value := GetEnumName(PropInfo^.PropType^, I);
         end;
       end;
    tkClass:
       begin  // 0 
         P := TPersistent(GetOrdProp(FOwner, PropInfo));
         if Assigned(P) and (P is TCollection)
            and (dps.cArgs =  1 ) then begin // 1 
           if ValidType(dps.rgvarg^[pDispIds^[ 0 ]], VT_BSTR,
               FALSE) then begin // 2 
             S := dps.rgvarg^[pDispIds^[ 0 ]].bstrVal;
             P1 := NIL;
             for I :=  0  to Pred(TCollection(P).Count) do
               if CompareText(S,
                 TCollection(P).Items[I].DisplayName)  =  0  then begin // 3 
                    P1 := TCollection(P).Items[I];
                    Break;
                // end; // 3 
              end; // 3 
             if Assigned(P1) then
               Value := FScriptControl.GetProxy(P1)
             else
               Result := DISP_E_MEMBERNOTFOUND;
           end else begin // 3 
             I :=IntValue(dps.rgvarg^[pDispIds^[ 0 ]]);
             if (I >=  0 ) and (I < TCollection(P).Count) then begin // 4 
               P := TCollection(P).Items[I];
               Value := FScriptControl.GetProxy(P);
             end else
               Result := DISP_E_MEMBERNOTFOUND;
           end;//  4 
end // 3 
else
         if Assigned(P) and (P is TStrings) and (dps.cArgs =  1 ) then
         begin // 1 
           if ValidType(dps.rgvarg^[pDispIds^[ 0 ]], VT_BSTR,
             FALSE) then begin // 2 
             S := dps.rgvarg^[pDispIds^[ 0 ]].bstrVal;
             Value := TStrings(P).Values[S];
            end else begin  // 3 
             I := IntValue(dps.rgvarg^[pDispIds^[ 0 ]]);
              if (I >=  0 ) and (I < TStrings(P).Count) then
                Value := TStrings(P)[I]
              else
               Result := DISP_E_MEMBERNOTFOUND;
              end; // 3 
           end; // 2 
           if Assigned(P) then
             Value := FScriptControl.GetProxy(P)
           else
             Value := Unassigned;
    end;
    tkFloat:
       begin
         if (PropInfo^.PropType^ = System.TypeInfo(TDateTime))or
            (PropInfo^.PropType^ = System.TypeInfo(TDate)) then
         begin
           Value := DT;
         end else
           Value := GetFloatProp(FOwner, PropInfo);
       end;
    tkSet:
       begin
         I := GetOrdProp(FOwner, PropInfo);
         Data := GetTypeData(PropInfo^.PropType^);
         TypeInfo := Data^.CompType^;
         S := '';
         if I <>  0  then begin
           for K :=  0  to  31  do begin
             J :=  1  shl K;
             if (J and I) = J then
               S := S + GetEnumName(TypeInfo, K) + ',';
           end;
           System.Delete(S, Length(S),  1 );
         end;
         Value := S;
       end;
    tkVariant:
       Value := GetVariantProp(FOwner, PropInfo);
   else
     Result := DISP_E_MEMBERNOTFOUND;
  end;
end;



constructor TVCLProxy.Create(AOwner: TPersistent;
  ScriptControl: TVFPConnector);
begin
  FOwner:=AOwner;
  FScriptControl:=ScriptControl;
end;

destructor TVCLProxy.Destroy;
begin

  inherited;
end;

function TVCLProxy.GetPersistent: TPersistent;
begin
  Result:=FOwner;
end;

function TVCLProxy.GetTypeInfo(Index, LocaleID: Integer;
  out TypeInfo): HResult;
begin
  if index= 0  then begin
      ITypeInfo(TypeInfo):=TTypeinfoPlug.Create(Self, FOwner.ClassName) as ITypeInfo;
      Result := S_OK;
  end
  else
    Result:=DISP_E_BADINDEX;
end;

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

function TVCLProxy.Invoke(DispID: Integer; const IID: TGUID;
  LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo,
  ArgErr: Pointer): HResult;
begin
 Result:=DoInvoke(DispId,
                  IID,
                  LocaleID,
                  Flags,
                  tagDispParams(Params),
                  pDispiDList(tagDispParams(Params).rgdispidNamedArgs),
                  VarResult,
                  ExcepInfo,
                  ArgErr);
end;

function TVCLEnum.Reset: HResult;
begin
  FEnumPosition :=  0 ;
  Result:=S_OK;
end;

{ TVFPConnector }

constructor TVFPConnector.Create(AOwner: TComponent);
var i: integer;

begin
  inherited Create(AOwner);
  FCode:=TStringList.Create;
  FNamedItems:=TNameditemList.Create(Self);
  FVFP:=CoVFPOLEServer.Create;
  if Owner is TCustomForm then
      SetForm(TCustomForm(Owner))
  else
      SetForm(GetParentForm(TControl(Owner)));
end;

destructor TVFPConnector.Destroy;
begin
  FCode.Free;
  FVFP:=nil;
  inherited;
end;

function TVFPConnector.Execute: OleVariant;
begin
  Result:=Unassigned;
  if Assigned(FVFP) then Result:=FVFP.NAFunct(WideString(FCode.Text));
end;

procedure TVFPConnector.FreeItems;
begin
  FNamedItems.Clear;
end;

function TVFPConnector.GetProxy(P: TPersistent): OleVariant;
var
    Dispatch: IDispatch;
begin
  Dispatch:=NamedItems.FindItem(TComponent(P).Name);
  if Dispatch = nil then
      Dispatch:=TVCLProxy.Create(P, Self) as IDispatch;
  NamedItems.AddItem(TComponent(P).Name, Dispatch);
  Result:=Dispatch;
end;

procedure TVFPConnector.RegisterClass(AName: string; PC: TPersistent);
var
    Dispatch: IDispatch;
begin
  Dispatch:=NamedItems.FindItem(TComponent(PC).Name);
  if Dispatch = nil then begin
     Dispatch:=TVCLProxy.Create(PC, Self) as IDispatch;
     NamedItems.AddItem(TComponent(PC).Name, Dispatch);
  end;
end;


function TVCLProxy.SetVCLProperty(PropInfo: PPropInfo;
   Argument: TVariantArg): HResult;
 var
   I, J, K, CommaPos: Integer;
   GoodToken: Boolean;
   S, S1: string;
   DT: TDateTime;
   ST: TSystemTime;
   IP: IQueryPersistent;
   Data, TypeData: PTypeData;
   TypeInfo: PTypeInfo;

function ValidType(n_arg: TVariantArg; chk_type: integer; cond: boolean): boolean;
begin
  Result:= n_arg.vt = chk_type;
  if not Result and cond then
    raise Exception.Create('Íåñîîòâåòâèå òèïà !');
end;

function IntValue(cn: TVariantArg): integer;
begin
  Result:=cn.intVal;
end;


 begin
   Result := S_OK;
   case PropInfo^.PropType^.Kind  of
    tkChar, tkString, tkLString, tkWChar, tkWString:
       begin
         ValidType(Argument, VT_BSTR, TRUE);
         SetStrProp(FOwner, PropInfo, Argument.bstrVal);
       end;
    tkInteger:
       begin
          if (CompareText(PropInfo^.PropType^.Name, 'TCURSOR') =  0 ) and
            (Argument.vt = VT_BSTR) then begin  // 1 
           if not IdentToCursor(Argument.bstrVal, I) then begin  // 2 
             Result := DISP_E_BADVARTYPE;
             Exit;
           end;  // 2 
         end {// 1 } else
         if (CompareText(PropInfo^.PropType^.Name, 'TCOLOR') =  0 ) and
           (Argument.vt = VT_BSTR) then begin // 1 
            if not IdentToColor(Argument.bstrVal, I) then begin
             Result := DISP_E_BADVARTYPE;
             Exit;
            end;
         end else
           I := IntValue(Argument);
         SetOrdProp(FOwner, PropInfo, I);
       end;
    tkEnumeration:
       begin
         if CompareText(PropInfo^.PropType^.Name, 'BOOLEAN') =  0  then
         begin
           ValidType(Argument, VT_BOOL, TRUE);
           SetOrdProp(FOwner, PropInfo, Integer(Argument.vBool));
         end else begin
           ValidType(Argument, VT_BSTR, TRUE);
           S := Trim(Argument.bstrVal);
           I := GetEnumValue(PropInfo^.PropType^, S);
           if I >=  0  then
             SetOrdProp(FOwner, PropInfo, I)
           else
             raise Exception.Create('');
         end;
        end;
    tkClass:
         begin
           ValidType(Argument, VT_DISPATCH,    TRUE);
           if Assigned(Argument.dispVal) then begin
             IP := IDispatch(Argument.dispVal) as IQueryPersistent;
             I := Integer(IP.GetPersistent);
           end else
             I :=  0 ;
           SetOrdProp(FOwner, PropInfo, I);
         end;
   tkFloat:
       begin
         if (PropInfo^.PropType^ = System.TypeInfo(TDateTime)) or
            (PropInfo^.PropType^ = System.TypeInfo(TDate)) then
 begin
           if Argument.vt = VT_BSTR then begin
             DT := StrToDate(Argument.bstrVal);
           end else begin
             ValidType(Argument, VT_DATE, TRUE);
             if VariantTimeToSystemTime(Argument.date, ST) <>  0  then
               DT := SystemTimeToDateTime(ST)
             else begin
               Result := DISP_E_BADVARTYPE;
               Exit;
             end;
           end;
           SetFloatProp(FOwner, PropInfo, DT);
         end else begin
           ValidType(Argument, VT_R8, TRUE);
           SetFloatProp(FOwner, PropInfo, Argument.dblVal);
         end;
       end;
   tkSet:
       begin

         ValidType(Argument, VT_BSTR, TRUE);
         S := Trim(Argument.bstrVal);

         Data := GetTypeData(PropInfo^.PropType^);
         TypeInfo := Data^.CompType^;
         TypeData := GetTypeData(TypeInfo);
         I :=  0 ;
         while Length(S) >  0  do begin
           CommaPos := Pos(',', S);
           if CommaPos =  0  then
             CommaPos := Length(S) +  1 ;
           S1 := Trim(System.Copy(S,  1 , CommaPos -  1 ));
           System.Delete(S,  1 , CommaPos);
           if Length(S1) >  0  then begin
             K :=  1 ;
             GoodToken := FALSE;
             for J := TypeData^.MinValue to TypeData^.MaxValue do
             begin
               if CompareText(S1, GetEnumName(TypeInfo , J)) =  0  then
                begin
                 I := I or K;
                 GoodToken := TRUE;
               end;
               K := K shl  1 ;
             end;
             if not GoodToken then begin
               Result := DISP_E_BADVARTYPE;
               Exit;
             end;
           end;
         end;
         SetOrdProp(FOwner, PropInfo, I);
       end;
    tkVariant:
       begin
         ValidType(Argument, VT_VARIANT, TRUE);
         SetVariantProp(FOwner, PropInfo, Argument.pvarVal^);
       end;
    else
      Result := DISP_E_MEMBERNOTFOUND;
   end;
 end;


 constructor TVCLEnum.Create(AOwner: TPersistent;
   AScriptControl: TVFPConnector);
 begin
   inherited Create;
   FOwner := AOwner;
   FScriptControl := AScriptControl;
   FEnumPosition :=  0 ;
 end;

 function TVCLEnum.Next(celt: LongWord; var rgvar: OleVariant;
   pceltFetched: PLongWord): HResult;
 var
   I: Cardinal;
 begin
   Result := S_OK;
   I :=  0 ;
  if FOwner is TWinControl then begin
     with TWinControl(FOwner) do begin
       while (FEnumPosition < ControlCount) and (I < celt) do begin
         TVariantList(rgvar)[I] :=
           FScriptControl.GetProxy(Controls[FEnumPosition]);
         Inc(I);
         Inc(FEnumPosition);
       end;
     end;
 end
 else
   if FOwner is TCollection then begin
     with TCollection(FOwner) do begin
       while (FEnumPosition < Count) and (I < celt) do begin
         TVariantList(rgvar)[I] :=
           FScriptControl.GetProxy(Items[FEnumPosition]);
         Inc(I);
         Inc(FEnumPosition);
       end;
     end;
 end
else
   if FOwner is TStrings then begin
     with TStrings(FOwner) do begin
       while (FEnumPosition < Count) and (I < celt) do begin
         TVariantList(rgvar)[I] := TStrings(FOwner)[FEnumPosition];
         Inc(I);
         Inc(FEnumPosition);
       end;
     end;
   end else
     Result := S_FALSE;
   if I <> celt then
     Result := S_FALSE;
   if Assigned(pceltFetched) then
     pceltFetched^ := I;
 end;

 function  TVCLEnum.Skip(celt: LongWord): HResult;
 var
   Total: Integer;
 begin
   Result := S_FALSE;
   if FOwner is TWinControl then
     Total := TWinControl(FOwner).ControlCount
   else
   if FOwner is TCollection then
     Total := TCollection(FOwner).Count
   else
   if FOwner is TStrings then
     Total := TStrings(FOwner).Count
   else
     Exit;
   if FEnumPosition + celt <= Total then begin
     Result := S_OK;
     Inc(FEnumPosition, celt)
   end;
 end;

function TVCLEnum.Clone(out Enum: IEnumVariant): HResult;
 var
   NewEnum: TVCLEnum;
 begin
   NewEnum := TVCLEnum.Create(FOwner, FScriptControl);
   NewEnum.FEnumPosition := FEnumPosition;
   Enum := NewEnum as IEnumVariant;
   Result := S_OK;
 end;


procedure TVFPConnector.SetCode(const Value: TStringList);
begin
  FCode.Assign(Value);
end;

procedure TVFPConnector.SetForm(frm: TCustomForm);
var i: integer;
begin
  if Assigned(frm) then begin
    NamedItems.Clear;
    NamedItems.AddItem('Self', TVCLProxy.Create(frm, Self));
    for i:= 0  to frm.ComponentCount -  1  do begin
       NamedItems.AddItem(frm.Components[i].Name, GetProxy(frm.Components[i]));
    end;
  end;

end;

{ TNamedItemList }

procedure TNamedItemList.AddItem(const Name: string; Item: IDispatch);
var i1: TNameditem;
begin
  i1:=TNameditem.Create;
  i1.FDispatch:=item;
  i1.FName:=AnsiUpperCase(Name);
  Add(i1);
  if Assigned(FConnector.FVFP) and (Name<>'') then
      FConnector.FVFP.AddDispatch(item, WideString(Name));
end;

procedure TNamedItemList.Clear;
var i: integer;
begin
  if not (csDestroying in FConnector.Owner.ComponentState) then begin
  FConnector.FVFP.FreeDispatch('Self');
  for i:= 0  to Self.Count -  1  do
    FConnector.FVFP.FreeDispatch(TNamedItem(Items[i]).FName);
  end;
  inherited;
end;



constructor TNamedItemList.Create(Connector: TVFPConnector);
begin
  inherited Create;
  FConnector:=Connector;
end;

function TNamedItemList.FindItem(Item: string): IDispatch;
var i: integer;
begin
  Result:=nil;
  for i:= 0  to count -  1  do begin
    if SameText(TNamedItem(Items[i]).FName, Item) then begin
      Result:=TNamedItem(Items[i]).FDispatch;
      break;
    end;
  end;
end;

function TNamedItemList.GetItemIDispatch(const Name: string): IDispatch;
begin
  Result:=FindItem(Name);
end;

{ TTypeinfoPlug }

function TTypeinfoPlug.AddressOfMember(memid: TMemberID;
  invkind: TInvokeKind; out ppv: Pointer): HResult;
begin
  Result:=E_FAiL;
end;

constructor TTypeinfoPlug.Create(AOwner: TVCLProxy; ClassNameStr: WideString);
begin
  FClassNameStr:=ClassNameStr;
  FOwner:=AOwner;
end;

function TTypeinfoPlug.CreateInstance(const unkOuter: IInterface;
  const iid: TIID; out vObj): HResult;
begin
  Result:=E_NOTiMPL;
end;

function TTypeinfoPlug.GetContainingTypeLib(out tlib: ITypeLib;
  out pindex: Integer): HResult;
begin
  Result:=E_NOTiMPL;
end;

function TTypeinfoPlug.GetDllEntry(memid: TMemberID; invkind: TInvokeKind;
  bstrDllName, bstrName: PWideString; wOrdinal: PWord): HResult;
begin
  Result:=E_FAiL;
end;

function TTypeinfoPlug.GetDocumentation(memid: TMemberID; pbstrName,
  pbstrDocString: PWideString; pdwHelpContext: PLongint;
  pbstrHelpFile: PWideString): HResult;
begin
  if Memid = MEMBERiD_Nil then begin
    if pbstrName <> nil then pbstrName^:=FClassNameStr;
    if pbstrDocString <> nil then pbstrDocString^ := '';
    result:=S_OK;
  end else
    Result:=E_FAiL;
end;

function TTypeinfoPlug.GetFuncDesc(index: Integer;
  out pfuncdesc: PFuncDesc): HResult;
begin
  Result:=E_NOTiMPL;
end;

function TTypeinfoPlug.GetIDsOfNames(rgpszNames: POleStrList;
  cNames: Integer; rgmemid: PMemberIDList): HResult;
begin
   Result:=FOwner.GetIDsOfNames(GUID_NULL, rgpszNames, Length(rgpszNames^),  0 , rgmemid);
end;

function TTypeinfoPlug.GetImplTypeFlags(index: Integer;
  out impltypeflags: Integer): HResult;
begin
  impltypeflags:=iMPLTYPEFLAG_FDEFAULT;
  result:=S_OK;
end;

function TTypeinfoPlug.GetMops(memid: TMemberID;
  out bstrMops: WideString): HResult;
begin
  Result:=E_NOTiMPL;
end;

function TTypeinfoPlug.GetNames(memid: TMemberID; rgbstrNames: PBStrList;
  cMaxNames: Integer; out cNames: Integer): HResult;
begin
   Result:=E_NOTiMPL;
end;

function TTypeinfoPlug.GetRefTypeInfo(reftype: HRefType;
  out tinfo: ITypeInfo): HResult;
begin
   Result:=Queryinterface(iTypeinfo, tinfo);
end;


function TTypeinfoPlug.GetRefTypeOfImplType(index: Integer;
  out reftype: HRefType): HResult;
begin
  reftype:= 0 ;
  Result:=S_OK;
end;
var TypeAttr: TTypeAttr;

function TTypeinfoPlug.GetTypeAttr(out ptypeattr: PTypeAttr): HResult;
begin
  FillChar(TypeAttr, SizeOf(TypeAttr), 0 );
  with TypeAttr do begin
    cimplTypes:= 1 ;
    guid:=iDispatch;
  end;
  pTypeAttr:=@TypeAttr;
  Result:=S_OK;
end;

function TTypeinfoPlug.GetTypeComp(out tcomp: ITypeComp): HResult;
begin
   iTypeComp(tcomp):=TTypeCompStub.Create(FOwner) as iTypeComp;
   Result:=S_OK;
end;

function TTypeinfoPlug.GetVarDesc(index: Integer;
  out pvardesc: PVarDesc): HResult;
begin
  Result:=E_NOTiMPL;
end;

function TTypeinfoPlug.Invoke(pvInstance: Pointer; memid: TMemberID;
  flags: Word; var dispParams: TDispParams; varResult: PVariant;
  excepInfo: PExcepInfo; argErr: PInteger): HResult;
begin
   Result:=FOwner.Invoke(memid,
                          GUiD_NULL,
                           0 ,
                          flags,
                          dispParams,
                          varResult,
                          excepInfo,
                          argErr);
end;

procedure TTypeinfoPlug.ReleaseFuncDesc(pfuncdesc: PFuncDesc);
begin
end;

procedure TTypeinfoPlug.ReleaseTypeAttr(ptypeattr: PTypeAttr);
begin
end;

procedure TTypeinfoPlug.ReleaseVarDesc(pvardesc: PVarDesc);
begin
end;

{ TTypeCompStub }

function TTypeCompStub.Bind(szName: POleStr; lHashVal: Integer;
  wflags: Word; out tinfo: ITypeInfo; out desckind: TDescKind;
  out bindptr: TBindPtr): HResult;
begin
   Result:=E_NOTiMPL;
end;

function TTypeCompStub.BindType(szName: POleStr; lHashVal: Integer;
  out tinfo: ITypeInfo; out tcomp: ITypeComp): HResult;
begin
   Result:=E_NOTiMPL;
end;

constructor TTypeCompStub.Create(AOwner: TVCLProxy);
begin
  FOwner:=AOwner;
end;

initialization
  Coinitialize(nil);
finalization
  CoUninitialize;
end.