jvole2auto.pas

East make Tray Icon in delphi

begin
  Result := FOleInitialized;
end;

procedure CheckOleInitialized;
begin
  if not FOleInitialized then
    raise EOleError.Create(SOleNotInit);
end;

{$IFNDEF COMPILER3_UP}
function OleErrorMsg(ErrorCode: HResult): string;
begin
  FmtStr(Result, SOleError, [Longint(ErrorCode)]);
end;
{$ENDIF}

{$IFNDEF WIN32}

procedure OleError(ErrorCode: HResult);
begin
  raise EOleError.Create(OleErrorMsg(ErrorCode));
end;

{ Raise EOleError exception if result code indicates an error }

procedure OleCheck(OleResult: HResult);
begin
  if FailedHR(OleResult) then
    OleError(OleResult);
end;

{$ENDIF WIN32}

{ Raise exception given an OLE return code and TExcepInfo structure }

procedure DispInvokeError(Status: HResult; const ExcepInfo: TExcepInfo);
{$IFDEF COMPILER3_UP}
begin
  DispatchInvokeError(Status, ExcepInfo);
end;
{$ELSE}
var
  EClass: ExceptClass;
  Msg: string;
begin
  EClass := EOleError;
  if Longint(Status) <> DISP_E_EXCEPTION then
    Msg := OleErrorMsg(Status)
  else
    with ExcepInfo do
    begin
      try
        if (scode = CTL_E_SETNOTSUPPORTED) or
          (scode = CTL_E_SETNOTSUPPORTEDATRUNTIME) then
          EClass := EPropReadOnly
        else
        if (scode = CTL_E_GETNOTSUPPORTED) or
          (scode = CTL_E_GETNOTSUPPORTEDATRUNTIME) then
          EClass := EPropWriteOnly;
        if bstrDescription <> nil then
        begin
          Msg := OleStrToString(bstrDescription);
          while (Length(Msg) > 0) and
            (Msg[Length(Msg)] in [#0..#32, '.']) do
            Delete(Msg, Length(Msg), 1);
        end;
      finally
        if bstrSource <> nil then
          SysFreeString(bstrSource);
        if bstrDescription <> nil then
          SysFreeString(bstrDescription);
        if bstrHelpFile <> nil then
          SysFreeString(bstrHelpFile);
      end;
    end;
  if Msg = '' then
    Msg := OleErrorMsg(Status);
  raise EClass.Create(Msg);
end;
{$ENDIF COMPILER3_UP}

{$IFNDEF WIN32}

{ Convert a string to a class ID }

function StringToClassID(const S: string): CLSID;
var
  CharBuf: array [0..64] of Char;
begin
  OleCheck(CLSIDFromString(StrPLCopy(CharBuf, S, SizeOf(CharBuf) - 1), Result));
end;

{ Convert a class ID to a string }

function ClassIDToString(const CLSID: CLSID): string;
var
  P: PChar;
  Malloc: IMalloc;
begin
  OleCheck(CoGetMalloc(MEMCTX_TASK, Malloc));
  OleCheck(StringFromCLSID(CLSID, P));
  Result := StrPas(P);
  Malloc.Free(P);
end;

{ Create an OLE object variant given an IDispatch }

function VarFromInterface(Unknown: IUnknown): Variant;
var
  Disp: IDispatch;
begin
  VariantClear(VARIANTARG(Result));
  VariantInit(VARIANTARG(Result));
  try
    if Unknown <> nil then
    begin
      OleCheck(Unknown.QueryInterface(IID_IDispatch, Disp));
      Result.VT := VT_DISPATCH;
      Result.pdispVal := Dispatch.IDispatch(Disp);
    end;
  except
    VariantClear(VARIANTARG(Result));
    raise;
  end;
end;

{ Return OLE object stored in a variant }

function VarToInterface(const V: Variant): IDispatch;
begin
  Result := nil;
  if V.VT = VT_DISPATCH then
    Result := IDispatch(V.pdispVal)
  else
  if V.VT = (VT_DISPATCH or VT_BYREF) then
    Result := IDispatch(V.ppdispVal^);
  if Result = nil then
    raise EOleError.Create(SOleNotReference);
end;

{ Create an OLE object variant given a class name }

function CreateOleObject(const ClassName: string): Variant;
var
  Unknown: IUnknown;
  ClassID: CLSID;
  CharBuf: array [0..127] of Char;
begin
  StrPLCopy(CharBuf, ClassName, SizeOf(CharBuf) - 1);
  OleCheck(CLSIDFromProgID(@CharBuf, ClassID));
  OleCheck(CoCreateInstance(ClassID, nil, CLSCTX_INPROC_SERVER or
    CLSCTX_LOCAL_SERVER, IID_IUnknown, Unknown));
  try
    Result := VarFromInterface(Unknown);
  finally
    Unknown.Release;
  end;
end;

{ Get active OLE object for a given class name }

function GetActiveOleObject(const ClassName: string): Variant;
var
  Unknown: IUnknown;
  ClassID: CLSID;
  CharBuf: array [0..127] of Char;
begin
  StrPLCopy(CharBuf, ClassName, SizeOf(CharBuf) - 1);
  OleCheck(CLSIDFromProgID(@CharBuf, ClassID));
  OleCheck(GetActiveObject(ClassID, nil, Unknown));
  try
    Result := VarFromInterface(Unknown);
  finally
    Unknown.Release;
  end;
end;

{ OLE string support }

function OleStrToString(Source: BSTR): string;
begin
  Result := StrPas(Source);
end;

function StringToOleStr(const Source: string): BSTR;
var
  SourceLen: Integer;
  CharBuf: array [0..255] of Char;
begin
  SourceLen := Length(Source);
  if SourceLen > 0 then
  begin
    StrPLCopy(CharBuf, Source, SizeOf(CharBuf) - 1);
    Result := SysAllocStringLen(CharBuf, SourceLen);
  end
  else
    Result := nil;
end;

{$ELSE}

{ Return OLE object stored in a variant }

{$IFDEF COMPILER3_UP}
function VarToInterface(const V: Variant): IDispatch;
begin
  Result := nil;
  if TVarData(V).VType = varDispatch then
    Result := IDispatch(TVarData(V).VDispatch)
  else
  if TVarData(V).VType = (varDispatch or varByRef) then
    Result := IDispatch(Pointer(TVarData(V).VPointer^));
  if Result = nil then
    raise EOleError.Create(SOleNotReference);
end;
{$ENDIF}

{$ENDIF}

{ Assign Variant }

procedure AssignVariant(
  var Dest: {$IFDEF WIN32} TVariantArg; {$ELSE} Variant; {$ENDIF}
  const Value: TVarRec);
begin
  {$IFNDEF WIN32}
  VariantInit(VARIANTARG(Dest));
  try
  {$ENDIF}
    with Value do
      case VType of
        vtInteger:
          begin
            Dest.vt := VT_I4;
            Dest.lVal := VInteger;
          end;
        vtBoolean:
          begin
            Dest.vt := VT_BOOL;
            Dest.vbool := VBoolean;
          end;
        vtChar:
          begin
            Dest.vt := VT_BSTR;
            Dest.bstrVal := StringToOleStr(VChar);
          end;
        vtExtended:
          begin
            Dest.vt := VT_R8;
            Dest.dblVal := VExtended^;
          end;
        vtString:
          begin
            Dest.vt := VT_BSTR;
            Dest.bstrVal := StringToOleStr(VString^);
          end;
        vtPointer:
          if VPointer = nil then
          begin
            Dest.vt := VT_NULL;
            Dest.byRef := nil;
          end
          else
          begin
            Dest.vt := VT_BYREF;
            Dest.byRef := VPointer;
          end;
        vtPChar:
          begin
            Dest.vt := VT_BSTR;
            Dest.bstrVal := StringToOleStr(StrPas(VPChar));
          end;
        vtObject:
          begin
            Dest.vt := VT_BYREF;
            Dest.byRef := VObject;
          end;
        {$IFDEF WIN32}
        vtClass:
          begin
            Dest.vt := VT_BYREF;
            Dest.byRef := VClass;
          end;
        vtWideChar:
          begin
            Dest.vt := VT_BSTR;
            Dest.bstrVal := @VWideChar;
          end;
        vtPWideChar:
          begin
            Dest.vt := VT_BSTR;
            Dest.bstrVal := VPWideChar;
          end;
        vtAnsiString:
          begin
            Dest.vt := VT_BSTR;
            Dest.bstrVal := StringToOleStr(string(VAnsiString));
          end;
        vtCurrency:
          begin
            Dest.vt := VT_CY;
            Dest.cyVal := VCurrency^;
          end;
        vtVariant:
          begin
            Dest.vt := VT_BYREF or VT_VARIANT;
            Dest.pvarVal := VVariant;
          end;
        {$ENDIF WIN32}
        {$IFDEF COMPILER4_UP}
        vtInterface:
          begin
            Dest.vt := VT_UNKNOWN or VT_BYREF;
            Dest.byRef := VInterface;
          end;
        vtInt64:
          begin
            Dest.vt := VT_I8 or VT_BYREF;
            Dest.byRef := VInt64;
          end;
        {$ENDIF COMPILER4_UP}
      else
        raise EOleError.Create(SOleInvalidParam);
      end;
  {$IFNDEF WIN32}
  except
    VariantClear(VARIANTARG(Dest));
    raise;
  end;
  {$ENDIF}
end;

{ TJvOleController }

constructor TJvOleController.Create;
begin
  inherited Create;
  {$IFDEF WIN32}
  FLocale := GetThreadLocale;
  {$ELSE}
  FLocale := LOCALE_SYSTEM_DEFAULT;
  {$ENDIF}
  try
    InitOLE;
  except
    Application.HandleException(Self);
  end;
end;

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

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

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

procedure TJvOleController.AssignIDispatch(V: Variant);
begin
  CheckOleInitialized;
  ClearObject;
  VarToInterface(V);
  {$IFDEF WIN32}
  VarCopy(FObject, V);
  {$ELSE}
  VariantCopy(VARIANTARG(FObject), V);
  {$ENDIF}
end;

procedure TJvOleController.ClearObject;
begin
  {$IFDEF WIN32}
  VarClear(FRetValue);
  VarClear(FObject);
  {$ELSE}