imp_activex.pas

Delphi脚本控件

                ArgPtr^[0] := varOleStr;
                ArgPtr^[2] := Integer(BStr);
              end;
              Inc(StrCount);
            end else
            begin
              VarPtr := PVarArg(ParamPtr);

              ArgPtr^[0] := VarPtr^[0];
              ArgPtr^[1] := VarPtr^[1];
              ArgPtr^[2] := VarPtr^[2];
              ArgPtr^[3] := VarPtr^[3];
              Inc(Integer(ParamPtr), 12);
            end;
          end else
          begin
            ArgPtr^[0] := ArgType;
            ArgPtr^[2] := ParamPtr^;
            if (ArgType >= varDouble) and (ArgType <= varDate) then
            begin
              Inc(Integer(ParamPtr), 4);
              ArgPtr^[3] := ParamPtr^;
            end;
          end;
          Inc(Integer(ParamPtr), 4);
        end;
        Inc(I);
      until I = ArgCount;
    end;
    DispParams.rgvarg := @Args;
    DispParams.rgdispidNamedArgs := @DispIDs[1];
    DispParams.cArgs := ArgCount;
    DispParams.cNamedArgs := CallDesc^.NamedArgCount;
    DispID := DispIDs[0];
    InvKind := CallDesc^.CallType;
    if InvKind = DISPATCH_PROPERTYPUT then
    begin
      if Args[0][0] and varTypeMask = varDispatch then
        InvKind := DISPATCH_PROPERTYPUTREF;
      DispIDs[0] := DISPID_PROPERTYPUT;
      Dec(Integer(DispParams.rgdispidNamedArgs), SizeOf(Integer));
      Inc(DispParams.cNamedArgs);
    end else
    begin

      if (InvKind = DISPATCH_METHOD) and (ArgCount = 0) and (Result <> nil) then
        InvKind := DISPATCH_METHOD or DISPATCH_PROPERTYGET;

    end;
    Status := Dispatch.Invoke(DispID, GUID_NULL, 0, InvKind, DispParams,
      Result, @ExcepInfo, nil);
    if Status <> 0 then DispatchInvokeError(Status, ExcepInfo);
    J := StrCount;
    while J <> 0 do
    begin
      Dec(J);
      with Strings[J] do
        if PStr <> nil then OleStrToStrVar(BStr, PStr^);
    end;
  finally
    K := StrCount;
    while K <> 0 do
    begin
      Dec(K);
      SysFreeString(Strings[K].BStr);
    end;
  end;
end;

{ Call GetIDsOfNames method on the given IDispatch interface }

{ Central call dispatcher }

procedure MyVarDispInvoke(Result: PVariant; const Instance: Variant;
  CallDesc : PCallDesc; Params: Pointer); cdecl;

  procedure RaiseException;
  begin
    raise EOleError.Create(SVarNotObject);
  end;

var
  Dispatch: Pointer;
  DispIDs: array[0..MaxDispArgs - 1] of Integer;
begin

  if TVarData(Instance).VType = varDispatch then
    Dispatch := TVarData(Instance).VDispatch
  else if TVarData(Instance).VType = (varDispatch or varByRef) then
    Dispatch := Pointer(TVarData(Instance).VPointer^)
  else
    RaiseException;

  GetIDsOfNames(IDispatch(Dispatch), @CallDesc^.ArgTypes[CallDesc^.ArgCount],
    CallDesc^.NamedArgCount + 1, @DispIDs);

  if Result <> nil then VarClear(Result^);

  MyDispatchInvoke(IDispatch(Dispatch), CallDesc, @DispIDs, Params, Result);
end;


function DispatchProcedure(ModeCall: Byte; const Instance: Variant; const Name: String;
                           const P: Variant; ParamsCount: Integer): Variant;
var
  CallDesc: TCallDesc;
  Params: array[0..100] of LongInt;
  S: ShortString;
  I, K, VCount: Integer;
  VT: Byte;
  D: Double;
  V: Variant;
  SS: array [0..30] of String;
begin
  FillChar(CallDesc, SizeOf(TCallDesc ), 0);
  FillChar(Params, SizeOf(Params), 0);

  S := Name;

  with CallDesc do
  begin
    CallType := ModeCall;
    NamedArgCount := 0;

    ArgCount := 0;
    K := -1;

    for I := 1 to ParamsCount do
    begin
      VT := TVarData(P[I]).VType;
      VCount := VarArrayDimCount(P[I]);

      ArgTypes[ArgCount] := VT;

      if (VT in [VarInteger,VarSmallInt,VarByte]) and (VCount=0) then
      begin
        Inc(K);
        Params[K] := P[I];
      end
      else if   VT = VarError then
      begin
//      Inc(K);
//      Params[K] := P[I];
      end
      else if VT = VarOleStr then
      begin
        ArgTypes[ArgCount] := VarStrArg;
        SS[I] := P[I];
        Inc(K);
        Params[K] := LongInt(SS[I]);
      end
      else if (VT = VarVariant) or (VT = VarDispatch) or (VCount > 0) then
      begin
        ArgTypes[ArgCount] := VarVariant;
        Inc(K);
        V := P[I];
        Move(V, Params[K], SizeOf(Variant));
        Inc(K);
        Inc(K);
        Inc(K);
      end
      else if (VT = VarDouble) or (VT = VarCurrency) then
      begin
        Inc(K);
        D := P[I];
        Move(D, Params[K], SizeOf(Double));
        Inc(K);
      end;

//    ArgTypes[ ArgCount ] := ArgTypes[ ArgCount ]{ or atByRef };
//    ArgTypes[ ArgCount ] := ArgTypes[ ArgCount ] or atTypeMask;

      Inc(ArgCount);
    end;

    Move(S[1], ArgTypes[ArgCount], Length(S));
  end;

  MyVarDispInvoke(@Result, Instance, @CallDesc, @Params);
end;

procedure ActiveXObject_GetProperty(M: TPAXMethodBody);
var
  ParamCount: Integer;
  I: Integer;
  Params: Variant;
  ModeCall: Byte;
  D, V, Value: Variant;
  X: ActiveXObject;
  S: String;
begin
  ParamCount := M.ParamCount;
  Params := VarArrayCreate([1, ParamCount], varVariant);
  for I:=1 to ParamCount do
  begin
    Value := M.Params[I - 1].AsVariant;

    if VarType(Value) = varBoolean then
    begin
      if Value then
        Params[I] := Integer(1)
      else
        Params[I] := Integer(0);
    end
    else if VarType(Value) = varScriptObject then
    begin
      Params[I] := ActiveXObject(VariantToScriptObject(Value).Instance).D;
    end
    else
      Params[I] := Value;
 end;
  ModeCall := DISPATCH_METHOD + DISPATCH_PROPERTYGET;
  D := ActiveXObject(M.Self).D;
  V := DispatchProcedure(ModeCall, D, M.Name, Params, ParamCount);

  with M do
    if VarType(V) = varDispatch then
    begin
      // Make sure the object is properly cast as an IDispatch
      V := IUnknown(V) as IDispatch;
      if (IDispatch(V) <> NIL)
      then
      begin
        X := ActiveXObject.Create(M.Scripter);
        X.D := V;
        result.AsTObject := X;
      end
      else
        result.AsVariant := NULL;
    end
    else if VarType(V) = varOleStr then
    begin
      S := V;
      result.AsVariant := S;
    end
    else if VarType(V) = varEmpty then
    begin
      result.AsVariant := V;
    end
    else if VarType(V) = varNull then
    begin
      result.AsVariant := V;
    end
    else
      result.AsVariant := V;
end;

procedure ActiveXObject_PutProperty(M: TPAXMethodBody);
var
  ParamCount: Integer;
  I: Integer;
  Params: Variant;
  ModeCall: Byte;
  D, Value: Variant;
begin
  ParamCount := M.ParamCount;
  Params := VarArrayCreate([1, ParamCount], varVariant);
  for I:=1 to ParamCount do
  begin
    Value := M.Params[I - 1].AsVariant;

    if VarType(Value) = varBoolean then
    begin
      if Value then
        Params[I] := Integer(1)
      else
        Params[I] := Integer(0);
    end
    else if VarType(Value) = varScriptObject then
    begin
      Params[I] := ActiveXObject(VariantToScriptObject(Value).Instance).D;
    end
    else
      Params[I] := Value;
 end;
  ModeCall := DISPATCH_PROPERTYPUT;
  D := ActiveXObject(M.Self).D;
  DispatchProcedure(ModeCall, D, M.Name, Params, ParamCount);
end;

procedure Create_ActiveXObject(MethodBody: TPAXMethodBody);
begin
  with MethodBody do
  begin
    Self := ActiveXObject.Create(Scripter); //(TPAXBaseScripter(Scripter).ClassList.ActiveXClassRec);
    ActiveXObject(Self).D := CreateOleObject(Params[0].AsString);
  end;
end;

initialization
  CoInitialize(nil);

  with DefinitionList do
  begin
    AddClass2(ActiveXObject, nil, ActiveXObject_GetProperty,
                   ActiveXObject_PutProperty);
    AddMethod4(ActiveXObject, 'New', Create_ActiveXObject, 1);
    AddMethod4(ActiveXObject, 'Create', Create_ActiveXObject, 1);
    AddMethod4(ActiveXObject, 'ActiveXObject', Create_ActiveXObject, 1);
  end;
end.