jvole2auto.pas

East make Tray Icon in delphi

{-----------------------------------------------------------------------------
The contents of this file are subject to the Mozilla Public License
Version 1.1 (the "License"); you may not use this file except in compliance
with the License. You may obtain a copy of the License at
http://www.mozilla.org/MPL/MPL-1.1.html

Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for
the specific language governing rights and limitations under the License.

The Original Code is: JvOle2Auto.PAS, released on 2002-07-04.

The Initial Developers of the Original Code are: Fedor Koshevnikov, Igor Pavluk and Serge Korolev
Copyright (c) 1997, 1998 Fedor Koshevnikov, Igor Pavluk and Serge Korolev
Copyright (c) 2001,2002 SGB Software
All Rights Reserved.

Last Modified: 2002-07-04

You may retrieve the latest version of this file at the Project JEDI's JVCL home page,
located at http://jvcl.sourceforge.net

Known Issues:
-----------------------------------------------------------------------------}

{$I JVCL.INC}

unit JvOle2Auto;

interface

{$IFDEF WIN32}
uses
  Windows, SysUtils,
  {$IFDEF COMPILER3_UP}
  ActiveX, ComObj;
  {$ELSE}
  Ole2, OleAuto, OleCtl;
  {$ENDIF}
{$ELSE}
uses
  WinTypes, WinProcs, SysUtils, Ole2, Dispatch;
{$ENDIF}

const
  { Maximum number of dispatch arguments }
  {$IFDEF COMPILER3_UP}
  MaxDispArgs = 64;
  {$ELSE}
  MaxDispArgs = 32;
  {$ENDIF}

{$IFNDEF WIN32}
type
  TDispID = DISPID;
  PDispID = ^TDispID;
  TDispParams = DISPPARAMS;
  TLCID = LCID;
  TExcepInfo = EXCEPINFO;
  PDispIDList = ^TDispIDList;
  TDispIDList = array [0..MaxDispArgs] of TDispID;
  EOleError = class(EJVCLException);
{$ENDIF WIN32}

{$IFNDEF COMPILER3_UP}
type
  EPropReadOnly = class(EOleError);
  EPropWriteOnly = class(EOleError);
{$ENDIF}

{$IFNDEF WIN32}
const
  { Primary language IDs. }
  LANG_NEUTRAL = $00;

  LANG_AFRIKAANS = $36;
  LANG_ALBANIAN = $1C;
  LANG_ARABIC = $01;
  LANG_BASQUE = $2D;
  LANG_BELARUSIAN = $23;
  LANG_BULGARIAN = $02;
  LANG_CATALAN = $03;
  LANG_CHINESE = $04;
  LANG_CROATIAN = $1A;
  LANG_CZECH = $05;
  LANG_DANISH = $06;
  LANG_DUTCH = $13;
  LANG_ENGLISH = $09;
  LANG_ESTONIAN = $25;
  LANG_FAEROESE = $38;
  LANG_FARSI = $29;
  LANG_FINNISH = $0B;
  LANG_FRENCH = $0C;
  LANG_GERMAN = $07;
  LANG_GREEK = $08;
  LANG_HEBREW = $0D;
  LANG_HUNGARIAN = $0E;
  LANG_ICELANDIC = $0F;
  LANG_INDONESIAN = $21;
  LANG_ITALIAN = $10;
  LANG_JAPANESE = $11;
  LANG_KOREAN = $12;
  LANG_LATVIAN = $26;
  LANG_LITHUANIAN = $27;
  LANG_NORWEGIAN = $14;
  LANG_POLISH = $15;
  LANG_PORTUGUESE = $16;
  LANG_ROMANIAN = $18;
  LANG_RUSSIAN = $19;
  LANG_SERBIAN = $1A;
  LANG_SLOVAK = $1B;
  LANG_SLOVENIAN = $24;
  LANG_SPANISH = $0A;
  LANG_SWEDISH = $1D;
  LANG_THAI = $1E;
  LANG_TURKISH = $1F;
  LANG_UKRAINIAN = $22;
  LANG_VIETNAMESE = $2A;

  { Sublanguage IDs. }
  SUBLANG_NEUTRAL = $00; { language neutral }
  SUBLANG_DEFAULT = $01; { user default }
  SUBLANG_SYS_DEFAULT = $02; { system default }

  SUBLANG_CHINESE_TRADITIONAL = $01; { Chinese (Taiwan) }
  SUBLANG_CHINESE_SIMPLIFIED = $02; { Chinese (PR China) }
  SUBLANG_CHINESE_HONGKONG = $03; { Chinese (Hong Kong) }
  SUBLANG_CHINESE_SINGAPORE = $04; { Chinese (Singapore) }
  SUBLANG_DUTCH = $01; { Dutch }
  SUBLANG_DUTCH_BELGIAN = $02; { Dutch (Belgian) }
  SUBLANG_ENGLISH_US = $01; { English (USA) }
  SUBLANG_ENGLISH_UK = $02; { English (UK) }
  SUBLANG_ENGLISH_AUS = $03; { English (Australian) }
  SUBLANG_ENGLISH_CAN = $04; { English (Canadian) }
  SUBLANG_ENGLISH_NZ = $05; { English (New Zealand) }
  SUBLANG_ENGLISH_EIRE = $06; { English (Irish) }
  SUBLANG_FRENCH = $01; { French }
  SUBLANG_FRENCH_BELGIAN = $02; { French (Belgian) }
  SUBLANG_FRENCH_CANADIAN = $03; { French (Canadian) }
  SUBLANG_FRENCH_SWISS = $04; { French (Swiss) }
  SUBLANG_GERMAN = $01; { German }
  SUBLANG_GERMAN_SWISS = $02; { German (Swiss) }
  SUBLANG_GERMAN_AUSTRIAN = $03; { German (Austrian) }
  SUBLANG_ITALIAN = $01; { Italian }
  SUBLANG_ITALIAN_SWISS = $02; { Italian (Swiss) }
  SUBLANG_NORWEGIAN_BOKMAL = $01; { Norwegian (Bokmal) }
  SUBLANG_NORWEGIAN_NYNORSK = $02; { Norwegian (Nynorsk) }
  SUBLANG_PORTUGUESE = $02; { Portuguese }
  SUBLANG_PORTUGUESE_BRAZILIAN = $01; { Portuguese (Brazilian) }
  SUBLANG_SPANISH = $01; { Spanish (Castilian) }
  SUBLANG_SPANISH_MEXICAN = $02; { Spanish (Mexican) }
  SUBLANG_SPANISH_MODERN = $03; { Spanish (Modern) }

  { Default System and User IDs for language and locale. }
  LANG_SYSTEM_DEFAULT = (SUBLANG_SYS_DEFAULT shl 10) or LANG_NEUTRAL;
  LANG_USER_DEFAULT = (SUBLANG_DEFAULT shl 10) or LANG_NEUTRAL;
  LOCALE_SYSTEM_DEFAULT = (0 shl 16) or LANG_SYSTEM_DEFAULT;
  LOCALE_USER_DEFAULT = (0 shl 16) or LANG_USER_DEFAULT;

  { OLE control status codes }
  CTL_E_ILLEGALFUNCTIONCALL = $800A0000 + 5;
  CTL_E_OVERFLOW = $800A0000 + 6;
  CTL_E_OUTOFMEMORY = $800A0000 + 7;
  CTL_E_DIVISIONBYZERO = $800A0000 + 11;
  CTL_E_OUTOFSTRINGSPACE = $800A0000 + 14;
  CTL_E_OUTOFSTACKSPACE = $800A0000 + 28;
  CTL_E_BADFILENAMEORNUMBER = $800A0000 + 52;
  CTL_E_FILENOTFOUND = $800A0000 + 53;
  CTL_E_BADFILEMODE = $800A0000 + 54;
  CTL_E_FILEALREADYOPEN = $800A0000 + 55;
  CTL_E_DEVICEIOERROR = $800A0000 + 57;
  CTL_E_FILEALREADYEXISTS = $800A0000 + 58;
  CTL_E_BADRECORDLENGTH = $800A0000 + 59;
  CTL_E_DISKFULL = $800A0000 + 61;
  CTL_E_BADRECORDNUMBER = $800A0000 + 63;
  CTL_E_BADFILENAME = $800A0000 + 64;
  CTL_E_TOOMANYFILES = $800A0000 + 67;
  CTL_E_DEVICEUNAVAILABLE = $800A0000 + 68;
  CTL_E_PERMISSIONDENIED = $800A0000 + 70;
  CTL_E_DISKNOTREADY = $800A0000 + 71;
  CTL_E_PATHFILEACCESSERROR = $800A0000 + 75;
  CTL_E_PATHNOTFOUND = $800A0000 + 76;
  CTL_E_INVALIDPATTERNSTRING = $800A0000 + 93;
  CTL_E_INVALIDUSEOFNULL = $800A0000 + 94;
  CTL_E_INVALIDFILEFORMAT = $800A0000 + 321;
  CTL_E_INVALIDPROPERTYVALUE = $800A0000 + 380;
  CTL_E_INVALIDPROPERTYARRAYINDEX = $800A0000 + 381;
  CTL_E_SETNOTSUPPORTEDATRUNTIME = $800A0000 + 382;
  CTL_E_SETNOTSUPPORTED = $800A0000 + 383;
  CTL_E_NEEDPROPERTYARRAYINDEX = $800A0000 + 385;
  CTL_E_SETNOTPERMITTED = $800A0000 + 387;
  CTL_E_GETNOTSUPPORTEDATRUNTIME = $800A0000 + 393;
  CTL_E_GETNOTSUPPORTED = $800A0000 + 394;
  CTL_E_PROPERTYNOTFOUND = $800A0000 + 422;
  CTL_E_INVALIDCLIPBOARDFORMAT = $800A0000 + 460;
  CTL_E_INVALIDPICTURE = $800A0000 + 481;
  CTL_E_PRINTERERROR = $800A0000 + 482;
  CTL_E_CANTSAVEFILETOTEMP = $800A0000 + 735;
  CTL_E_SEARCHTEXTNOTFOUND = $800A0000 + 744;
  CTL_E_REPLACEMENTSTOOLONG = $800A0000 + 746;
  CTL_E_CUSTOM_FIRST = $800A0000 + 600;
{$ENDIF WIN32}

type
  { OLE2 Automation Controller }
  TJvOleController = class(TObject)
  private
    FLocale: TLCID;
    FObject: Variant;
    FRetValue: Variant;
    function CallMethod(ID: TDispID; const Params: array of const;
      NeedResult: Boolean): PVariant;
    function CallMethodNamedParams(const IDs: TDispIDList;
      const Params: array of const; Cnt: Byte; NeedResult: Boolean): PVariant;
    function CallMethodNoParams(ID: TDispID; NeedResult: Boolean): PVariant;
    function Invoke(DispIdMember: TDispID; WFlags: Word;
      var DispParams: TDispParams; Res: PVariant): PVariant;
    function NameToDispID(const AName: string): TDispID;
    function NameToDispIDs(const AName: string;
      const AParams: array of string; Dest: PDispIDList): PDispIDList;
  protected
    procedure ClearObject; virtual;
  public
    constructor Create;
    destructor Destroy; override;
    { create or assign OLE objects }
    procedure CreateObject(const ClassName: string); virtual;
    procedure AssignIDispatch(V: Variant); virtual;
    procedure GetActiveObject(const ClassName: string); virtual;
    { get/set properties of OLE object by ID }
    function GetPropertyByID(ID: TDispID): PVariant;
    procedure SetPropertyByID(ID: TDispID; const Prop: array of const);
    { get/set properties of OLE object }
    function GetProperty(const AName: string): PVariant;
    procedure SetProperty(const AName: string; const Prop: array of const);
    { call OLE functions by IDs }
    function CallFunctionByID(ID: TDispID; const Params: array of const): PVariant;
    function CallFunctionByIDsNamedParams(const IDs: TDispIDList;
      const Params: array of const; Cnt: Byte): PVariant;
    function CallFunctionNoParamsByID(ID: TDispID): PVariant;
    { call OLE procedures by ID }
    procedure CallProcedureByID(ID: TDispID; const Params: array of const);
    procedure CallProcedureByIDsNamedParams(const IDs: TDispIDList;
      const Params: array of const; Cnt: Byte);
    procedure CallProcedureNoParamsByID(ID: TDispID);
    { call OLE functions }
    function CallFunction(const AName: string; const Params: array of const): PVariant;
    function CallFunctionNamedParams(const AName: string; const Params: array of const;
      const ParamNames: array of string): PVariant;
    function CallFunctionNoParams(const AName: string): PVariant;
    { call OLE procedures }
    procedure CallProcedure(const AName: string; const Params: array of const);
    procedure CallProcedureNamedParams(const AName: string; const Params: array of const;
      const ParamNames: array of string);
    procedure CallProcedureNoParams(const AName: string);
    { locale }
    procedure SetLocale(PrimaryLangID, SubLangID: Word);
    property Locale: TLCID read FLocale write FLocale;
    property OleObject: Variant read FObject;
  end;

procedure InitOLE;
procedure DoneOLE;
function OleInitialized: Boolean;

function MakeLangID(PrimaryLangID, SubLangID: Word): Word;
function MakeLCID(LangID: Word): TLCID;
function CreateLCID(PrimaryLangID, SubLangID: Word): TLCID;
function ExtractLangID(LCID: TLCID): Word;
function ExtractSubLangID(LCID: TLCID): Word;

{$IFNDEF WIN32}

procedure OleCheck(OleResult: HResult);

{ OLE string support }
function OleStrToString(Source: BSTR): string;
function StringToOleStr(const Source: string): BSTR;
function StringToClassID(const S: string): CLSID;
function ClassIDToString(const CLSID: CLSID): string;

{ Create or get active OLE object for a given a class name }
function CreateOleObject(const ClassName: string): Variant;
function GetActiveOleObject(const ClassName: string): Variant;

{$ENDIF WIN32}

implementation

uses
  Forms;

{$IFDEF COMPILER3_UP}
resourcestring
{$ELSE}
const
{$ENDIF}
  SOleInvalidVer = 'Invalid OLE library version';
  SOleInitFailed = 'OLE Library initialization failed. Error code: %.8xH';
  SOleNotInit = 'OLE2 Library not initialized';
  SOleInvalidParam = 'Invalid parameter value';
  SOleNotSupport = 'Method or property %s not supported by OLE object';
  SOleNotReference = 'Variant does not reference an OLE automation object';
  {$IFNDEF COMPILER3_UP}
  SOleError = 'OLE2 error occured. Error code: %.8xH';
  {$ENDIF}

// (rom) changed to var
var
  FOleInitialized: Boolean = False;

const
  { OLE2 Version }
  RMJ = 0;
  RMM = 23;
  RUP = 639;

const
  DISPATCH_METHODNOPARAM = DISPATCH_METHOD or DISPATCH_PROPERTYGET;
  DISPATCH_METHODPARAMS = DISPATCH_METHOD {$IFDEF WIN32} or DISPATCH_PROPERTYGET {$ENDIF};

{$IFDEF WIN32}

function FailedHR(hr: HResult): Boolean;
begin
  Result := Failed(hr);
end;

{$ELSE WIN32}

{ Standard OLE class pathes }
type
  IDispatch = class(IUnknown)
    function GetTypeInfoCount(var PctInfo: Integer): HResult; virtual; cdecl; export; abstract;
    function GetTypeInfo(ItInfo: Integer; TLCID: TLCID; var PTInfo: ITypeInfo): HResult; virtual; cdecl; export;
      abstract;
    function GetIDsOfNames(const Riid: IID; var rgszNames: PChar;
      CNames: Integer; TLCID: TLCID; RgDispId: PDispID): HResult; virtual; cdecl; export; abstract;
    function Invoke(DispIdMember: TDispID; const Riid: IID; TLCID: TLCID;
      WFlags: Word; var DispParams: TDispParams; PVarResult: PVariant;
      var ExcepInfo: TExcepInfo; var UArgErr: Integer): HResult; virtual; cdecl; export; abstract;
  end;

function DispInvoke(_this: Pointer; PTInfo: ITypeInfo; DispIdMember: TDispID;
  WFlags: Word; var pparams: TDispParams; PVarResult: PVariant;
  var ExcepInfo: TExcepInfo; var UArgErr: Integer): HResult; far; external 'ole2disp';

function DispGetIDsOfNames(PTInfo: ITypeInfo; var rgszNames: PChar;
  CNames: Integer; RgDispId: PDispID): HResult; far; external 'ole2disp';

function GUID_NULL: GUID;
begin
  Result := IID_NULL;
end;

{$ENDIF WIN32}

{ Standard OLE Library initialization code }

procedure InitOLE;
var
  dwVer: Longint;
  HRes: HResult;
begin
  if FOleInitialized then
    Exit;
  dwVer := Longint(CoBuildVersion);
  if (RMM <> HiWord(dwVer)) or (RUP > LoWord(dwVer)) then
    raise EOleError.Create(SOleInvalidVer)
  else
  begin
    HRes := OleInitialize(nil);
    if FailedHR(HRes) then
      raise EOleError.CreateFmt(SOleInitFailed, [Longint(HRes)])
    else
      FOleInitialized := True;
  end;
end;

{ Standard OLE Library exit code }

procedure DoneOLE;
begin
  if FOleInitialized then
    OleUninitialize;
  FOleInitialized := False;
end;

function OleInitialized: Boolean;