rxole2auto.pas

rx library V2.7.7a component use in delphi7 to delphi 2006

          end;
{$ENDIF RX_D4}
        else raise EOleError.Create(SOleInvalidParam);
      end;
end;

{ TOleController }

constructor TOleController.Create;
begin
  inherited Create;
  FLocale := GetThreadLocale;
  try
    InitOLE;
  except
    Application.HandleException(Self);
  end;
end;

destructor TOleController.Destroy;
begin
  if FOleInitialized then ClearObject;
  inherited Destroy;
end;

procedure TOleController.CreateObject(const ClassName: string);
begin
  CheckOleInitialized;
  ClearObject;
  FObject := CreateOleObject(ClassName);
end;

procedure TOleController.GetActiveObject(const ClassName: string);
begin
  CheckOleInitialized;
  ClearObject;
  FObject := GetActiveOleObject(ClassName);
end;

procedure TOleController.AssignIDispatch(V: Variant);
begin
  CheckOleInitialized;
  ClearObject;
  VarToInterface(V);
  VarCopy(FObject, V);
end;

procedure TOleController.ClearObject;
begin
  VarClear(FRetValue);
  VarClear(FObject);
end;

function TOleController.NameToDispID(const AName: string): TDispID;
var
  CharBuf: array[0..255] of WideChar;
  P: array[0..0] of PWideChar;
begin
  CheckOleInitialized;
  StringToWideChar(AName, @CharBuf, 256);
  P[0] := @CharBuf[0];
  if FailedHR(VarToInterface(FObject).GetIDsOfNames(GUID_NULL,
    @P, 1, FLocale, @Result)) then
    raise EOleError.CreateFmt(SOleNotSupport, [AName]);
end;

function TOleController.NameToDispIDs(const AName: string;
  const AParams: array of string; Dest: PDispIDList): PDispIDList;
var
  CharBuf: array[0..MaxDispArgs] of PWideChar;
  Size: Integer;
  I: Byte;
begin
  Result := Dest;
  CheckOleInitialized;
  Size := Length(AName) + 1;
  GetMem(CharBuf[0], Size * SizeOf(WideChar));
  StringToWideChar(AName, CharBuf[0], Size);
  for I := 0 to High(AParams) do begin
    Size := Length(AParams[I]) + 1;
    GetMem(CharBuf[I + 1], Size * SizeOf(WideChar));
    StringToWideChar(AParams[I], CharBuf[I + 1], Size);
  end;
  try
    if FailedHR(VarToInterface(FObject).GetIDsOfNames(GUID_NULL,
      @CharBuf, 
      High(AParams) + 2, FLocale, @Result^[0]))
    then
      raise EOleError.CreateFmt(SOleNotSupport, [AName]);
  finally
    for I := 0 to High(AParams) + 1 do FreeMem(CharBuf[I]);
  end;
end;

function TOleController.Invoke(dispidMember: TDispID; wFlags: Word;
  var pdispparams: TDispParams; Res: PVariant): PVariant;
var
  pexcepinfo: TExcepInfo;
  puArgErr: Integer;
  HRes: HResult;
begin
  if Res <> nil then VarClear(Res^);
  try
    HRes := VarToInterface(FObject).Invoke(dispidMember, GUID_NULL,
      FLocale, wFlags, pdispparams, Res, @pexcepinfo, @puArgErr);
  except
    if Res <> nil then VarClear(Res^);
    raise;
  end;
  if FailedHR(HRes) then DispInvokeError(HRes, pexcepinfo);
  Result := Res;
end;

function TOleController.CallMethodNoParams(ID: TDispID;
  NeedResult: Boolean): PVariant;
const
  Disp: TDispParams = (rgvarg: nil; rgdispidNamedArgs: nil; cArgs: 0;
    cNamedArgs: 0);
begin
  CheckOleInitialized;
  if NeedResult then
    Result := Invoke(ID, DISPATCH_METHODNOPARAM, Disp, @FRetValue)
  else
    Result := Invoke(ID, DISPATCH_METHODNOPARAM, Disp, nil);
end;

function TOleController.CallMethod(ID: TDispID; const Params: array of const;
  NeedResult: Boolean): PVariant;
var
  Disp: TDispParams;
  ArgCnt, I: Integer;
  Args: array[0..MaxDispArgs - 1] of TVariantArg;
begin
  CheckOleInitialized;
  ArgCnt := 0;
  for I := 0 to High(Params) do begin
    AssignVariant(Args[I], Params[I]);
    Inc(ArgCnt);
    if ArgCnt >= MaxDispArgs then Break;
  end;
  with Disp do begin
    if ArgCnt = 0 then rgvarg := nil
    else rgvarg := @Args;
    rgdispidNamedArgs := nil;
    cArgs := ArgCnt;
    cNamedArgs := 0;
  end;
  if NeedResult then
    Result := Invoke(ID, DISPATCH_METHODPARAMS, Disp, @FRetValue)
  else
    Result := Invoke(ID, DISPATCH_METHODPARAMS, Disp, nil);
end;

function TOleController.CallMethodNamedParams(const IDs: TDispIDList;
  const Params: array of const; Cnt: Byte; NeedResult: Boolean): PVariant;
var
  Disp: TDispParams;
  ArgCnt, I: Integer;
  Args: array[0..MaxDispArgs - 1] of TVariantArg;
begin
  CheckOleInitialized;
  ArgCnt := 0;
  for I := 0 to High(Params) do begin
    AssignVariant(Args[I], Params[I]);
    Inc(ArgCnt);
    if ArgCnt >= MaxDispArgs then Break;
  end;
  with Disp do begin
    if ArgCnt = 0 then rgvarg := nil
    else rgvarg := @Args;
    if Cnt = 0 then rgdispidNamedArgs := nil
    else rgdispidNamedArgs := @IDs[1];
    cArgs := ArgCnt;
    cNamedArgs := Cnt;
  end;
  if NeedResult then
    Result := Invoke(IDs[0], DISPATCH_METHODPARAMS, Disp, @FRetValue)
  else
    Result := Invoke(IDs[0], DISPATCH_METHODPARAMS, Disp, nil);
end;

procedure TOleController.SetPropertyByID(ID: TDispID; const Prop: array of const);
const
  NameArg: TDispID = DISPID_PROPERTYPUT;
var
  Disp: TDispParams;
  ArgCnt, I: Integer;
  Args: array[0..MaxDispArgs - 1] of TVariantArg;
begin
  CheckOleInitialized;
  ArgCnt := 0;
  for I := 0 to High(Prop) do begin
    AssignVariant(Args[I], Prop[I]);
    Inc(ArgCnt);
    if ArgCnt >= MaxDispArgs then Break;
  end;
  with Disp do begin
    rgvarg := @Args;
    rgdispidNamedArgs := @NameArg;
    cArgs := ArgCnt;
    cNamedArgs := 1;
  end;
  Invoke(ID, DISPATCH_PROPERTYPUT, Disp, nil);
end;

function TOleController.GetPropertyByID(ID: TDispID): PVariant;
const
  Disp: TDispParams = (rgvarg: nil; rgdispidNamedArgs: nil;
    cArgs: 0; cNamedArgs: 0);
begin
  CheckOleInitialized;
  Result := Invoke(ID, DISPATCH_PROPERTYGET, Disp, @FRetValue);
end;

procedure TOleController.CallProcedureByID(ID: TDispID; const Params: array of const);
begin
  CallMethod(ID, Params, False);
end;

function TOleController.CallFunctionByID(ID: TDispID;
  const Params: array of const): PVariant;
begin
  Result := CallMethod(ID, Params, True);
end;

procedure TOleController.CallProcedureByIDsNamedParams(const IDs: TDispIDList;
  const Params: array of const; Cnt: Byte);
begin
  CallMethodNamedParams(IDs, Params, Cnt, False);
end;

function TOleController.CallFunctionByIDsNamedParams(const IDs: TDispIDList;
  const Params: array of const; Cnt: Byte): PVariant;
begin
  Result := CallMethodNamedParams(IDs, Params, Cnt, True);
end;

procedure TOleController.CallProcedureNoParamsByID(ID: TDispID);
begin
  CallMethodNoParams(ID, False);
end;

function TOleController.CallFunctionNoParamsByID(ID: TDispID): PVariant;
begin
  Result := CallMethodNoParams(ID, True);
end;

procedure TOleController.SetProperty(const AName: string;
  const Prop: array of const);
begin
  SetPropertyByID(NameToDispID(AName), Prop);
end;

function TOleController.GetProperty(const AName: string): PVariant;
begin
  Result := GetPropertyByID(NameToDispID(AName));
end;

procedure TOleController.CallProcedure(const AName: string;
  const Params: array of const);
begin
  CallProcedureByID(NameToDispID(AName), Params);
end;

function TOleController.CallFunction(const AName: string;
  const Params: array of const): PVariant;
begin
  Result := CallFunctionByID(NameToDispID(AName), Params);
end;

procedure TOleController.CallProcedureNamedParams(const AName: string;
  const Params: array of const; const ParamNames: array of string);
var
  DispIDs: array[0..MaxDispArgs] of TDispID;
begin
  CallProcedureByIDsNamedParams(NameToDispIDs(AName, ParamNames, @DispIDs)^,
    Params, High(ParamNames) + 1);
end;

function TOleController.CallFunctionNamedParams(const AName: string;
  const Params: array of const; const ParamNames: array of string): PVariant;
var
  DispIDs: array[0..MaxDispArgs] of TDispID;
begin
  Result := CallFunctionByIDsNamedParams(NameToDispIDs(AName, ParamNames,
    @DispIDs)^, Params, High(ParamNames) + 1);
end;

procedure TOleController.CallProcedureNoParams(const AName: string);
begin
  CallProcedureNoParamsByID(NameToDispID(AName));
end;

function TOleController.CallFunctionNoParams(const AName: string): PVariant;
begin
  Result := CallFunctionNoParamsByID(NameToDispID(AName));
end;

procedure TOleController.SetLocale(PrimaryLangID, SubLangID: Word);
begin
  FLocale := CreateLCID(PrimaryLangID, SubLangID);
end;

{ Utility routines }

function MakeLangID(PrimaryLangID, SubLangID: Word): Word;
begin
  Result := (SubLangID shl 10) or PrimaryLangID;
end;

function MakeLCID(LangID: Word): TLCID;
begin
  Result := TLCID(LangID or (Longint(0) shl 16));
end;

function CreateLCID(PrimaryLangID, SubLangID: Word): TLCID;
begin
  Result := MakeLCID(MakeLangID(PrimaryLangID, SubLangID));
end;

function ExtractLangID(LCID: TLCID): Word;
begin
  Result := LCID and $FF;
end;

function ExtractSubLangID(LCID: TLCID): Word;
begin
  Result := LCID and ($FF shl 10) shr 10;
end;

initialization
finalization
  DoneOLE;
end.