ole2auto.pas

RX Library contains a large number of components, objects and routines for Borland Delphi with full

begin
{$IFDEF WIN32}
  VarClear(FRetValue);
  VarClear(FObject);
{$ELSE}
  VariantClear(VARIANTARG(FRetValue));
  VariantClear(VARIANTARG(FObject));
{$ENDIF}
end;

function TOleController.NameToDispID(const AName: string): TDispID;
var
{$IFDEF WIN32}
  CharBuf: array[0..255] of WideChar;
  P: array[0..0] of PWideChar;
{$ELSE}
  CharBuf: array[0..255] of Char;
  P: PChar;
{$ENDIF}
begin
  CheckOleInitialized;
{$IFDEF WIN32}
  StringToWideChar(AName, @CharBuf, 256);
  P[0] := @CharBuf[0];
{$ELSE}
  StrPLCopy(CharBuf, AName, SizeOf(CharBuf) - 1);
  P := @CharBuf;
{$ENDIF}
  if FailedHR(VarToInterface(FObject).GetIDsOfNames(GUID_NULL,
    {$IFDEF WIN32} @P, {$ELSE} P, {$ENDIF} 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
{$IFDEF WIN32}
  CharBuf: array[0..MaxDispArgs] of PWideChar;
  Size: Integer;
{$ELSE}
  CharBuf: array[0..MaxDispArgs] of PChar;
{$ENDIF}
  I: Byte;
begin
  Result := Dest;
  CheckOleInitialized;
{$IFDEF WIN32}
  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;
{$ELSE}
  CharBuf[0] := StrPCopy(StrAlloc(Length(AName) + 1), AName);
  for I := 0 to High(AParams) do
    CharBuf[I + 1] := StrPCopy(StrAlloc(Length(AParams[I]) + 1), AParams[I]);
{$ENDIF}
  try
    if FailedHR(VarToInterface(FObject).GetIDsOfNames(GUID_NULL,
      {$IFDEF WIN32} @CharBuf, {$ELSE} CharBuf[0], {$ENDIF}
      High(AParams) + 2, FLocale, @Result^[0]))
    then
      raise EOleError.CreateFmt(SOleNotSupport, [AName]);
  finally
{$IFDEF WIN32}
    for I := 0 to High(AParams) + 1 do FreeMem(CharBuf[I]);
{$ELSE}
    for I := 0 to High(AParams) + 1 do StrDispose(CharBuf[I]);
{$ENDIF}
  end;
end;

function TOleController.Invoke(dispidMember: TDispID; wFlags: Word;
  var pdispparams: TDispParams; Res: PVariant): PVariant;
var
  pexcepinfo: TExcepInfo;
  puArgErr: Integer;
  HRes: HResult;
begin
{$IFDEF WIN32}
  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;
{$ELSE}
  if Res <> nil then begin
    VariantClear(VARIANTARG(Res^));
    VariantInit(VARIANTARG(Res^));
  end;
  try
    HRes := VarToInterface(FObject).Invoke(dispidMember, GUID_NULL,
      FLocale, wFlags, pdispparams, Res, pexcepinfo, puArgErr);
  except
    if Res <> nil then VariantClear(VARIANTARG(Res^));
    raise;
  end;
{$ENDIF}
  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;
{$IFDEF WIN32}
  Args: array[0..MaxDispArgs - 1] of TVariantArg;
{$ELSE}
  Args: array[0..MaxDispArgs - 1] of Variant;
{$ENDIF}
begin
  CheckOleInitialized;
  ArgCnt := 0;
  try
    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);
  finally
{$IFNDEF WIN32}
    for I := 0 to ArgCnt - 1 do VariantClear(VARIANTARG(Args[I]));
{$ENDIF}
  end;
end;

function TOleController.CallMethodNamedParams(const IDs: TDispIDList;
  const Params: array of const; Cnt: Byte; NeedResult: Boolean): PVariant;
var
  Disp: TDispParams;
  ArgCnt, I: Integer;
{$IFDEF WIN32}
  Args: array[0..MaxDispArgs - 1] of TVariantArg;
{$ELSE}
  Args: array[0..MaxDispArgs - 1] of Variant;
{$ENDIF}
begin
  CheckOleInitialized;
  ArgCnt := 0;
  try
    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);
  finally
{$IFNDEF WIN32}
    for I := 0 to ArgCnt - 1 do VariantClear(VARIANTARG(Args[I]));
{$ENDIF}
  end;
end;

procedure TOleController.SetPropertyByID(ID: TDispID; const Prop: array of const);
const
  NameArg: TDispID = DISPID_PROPERTYPUT;
var
  Disp: TDispParams;
  ArgCnt, I: Integer;
{$IFDEF WIN32}
  Args: array[0..MaxDispArgs - 1] of TVariantArg;
{$ELSE}
  Args: array[0..MaxDispArgs - 1] of Variant;
{$ENDIF}
begin
  CheckOleInitialized;
  ArgCnt := 0;
  try
    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);
  finally
{$IFNDEF WIN32}
    for I := 0 to ArgCnt - 1 do VariantClear(VARIANTARG(Args[I]));
{$ENDIF}
  end;
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;

{$IFDEF WIN32}
initialization
finalization
  DoneOLE;
{$ELSE}
initialization
  AddExitProc(DoneOLE);
{$ENDIF}
end.