jvole2auto.pas

East make Tray Icon in delphi

  VariantClear(VARIANTARG(FRetValue));
  VariantClear(VARIANTARG(FObject));
  {$ENDIF}
end;

function TJvOleController.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[0], 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 TJvOleController.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 TJvOleController.Invoke(DispIdMember: TDispID; WFlags: Word;
  var DispParams: TDispParams; Res: PVariant): PVariant;
var
  ExcepInfo: TExcepInfo;
  UArgErr: Integer;
  HRes: HResult;
begin
  {$IFDEF WIN32}
  if Res <> nil then
    VarClear(Res^);
  try
    HRes := VarToInterface(FObject).Invoke(DispIdMember, GUID_NULL,
      FLocale, WFlags, DispParams, Res, @ExcepInfo, @UArgErr);
  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, DispParams, Res, ExcepInfo, UArgErr);
  except
    if Res <> nil then
      VariantClear(VARIANTARG(Res^));
    raise;
  end;
  {$ENDIF}
  if FailedHR(HRes) then
    DispInvokeError(HRes, ExcepInfo);
  Result := Res;
end;

function TJvOleController.CallMethodNoParams(ID: TDispID;
  NeedResult: Boolean): PVariant;
var
  Disp: TDispParams;
begin
  FillChar(Disp, SizeOf(Disp), #0);
  CheckOleInitialized;
  if NeedResult then
    Result := Invoke(ID, DISPATCH_METHODNOPARAM, Disp, @FRetValue)
  else
    Result := Invoke(ID, DISPATCH_METHODNOPARAM, Disp, nil);
end;

function TJvOleController.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 := PVariantArgList(@Args[0]);
      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 TJvOleController.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 := PVariantArgList(@Args);
      if Cnt = 0 then
        rgdispidNamedArgs := nil
      else
        rgdispidNamedArgs := PDispIDList(@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 TJvOleController.SetPropertyByID(ID: TDispID; const Prop: array of const);
var
  Disp: TDispParams;
  ArgCnt, I: Integer;
  {$IFDEF WIN32}
  Args: array [0..MaxDispArgs - 1] of TVariantArg;
  {$ELSE}
  Args: array [0..MaxDispArgs - 1] of Variant;
  {$ENDIF}
  NameArg: TDispID;
begin
  NameArg := DISPID_PROPERTYPUT;
  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 := PVariantArgList(@Args[0]);
      rgdispidNamedArgs := PDispIDList(@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 TJvOleController.GetPropertyByID(ID: TDispID): PVariant;
var
  Disp: TDispParams;
begin
  FillChar(Disp, SizeOf(Disp), #0);
  CheckOleInitialized;
  Result := Invoke(ID, DISPATCH_PROPERTYGET, Disp, @FRetValue);
end;

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

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

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

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

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

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

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

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

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

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

procedure TJvOleController.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, PDispIDList(@DispIDs[0]))^,
    Params, High(ParamNames) + 1);
end;

function TJvOleController.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,
    PDispIDList(@DispIDs[0]))^, Params, High(ParamNames) + 1);
end;

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

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

procedure TJvOleController.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.