📄 ole2auto.pas
字号:
{*******************************************************}
{ }
{ Delphi VCL Extensions (RX) }
{ OLE2 Automation Controller }
{ }
{ Copyright (c) 1995, 1996 AO ROSNO }
{ Copyright (c) 1997 Master-Bank }
{ }
{*******************************************************}
unit Ole2Auto;
interface
{$I RX.INC}
{$IFDEF WIN32}
uses Windows, SysUtils, {$IFDEF RX_D3} ActiveX, ComObj {$ELSE}
Ole2, OleAuto, OleCtl {$ENDIF};
{$ELSE}
uses WinTypes, WinProcs, SysUtils, Ole2, Dispatch;
{$ENDIF}
const { Maximum number of dispatch arguments }
{$IFDEF RX_D3}
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(Exception);
{$ENDIF WIN32}
{$IFNDEF RX_D3}
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 }
TOleController = 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 pdispparams: 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 RX_D3}
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 RX_D3}
SOleError = 'OLE2 error occured. Error code: %.8xH';
{$ENDIF}
const
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 pptinfo: 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 pdispparams: TDispParams; pvarResult: PVARIANT;
var pexcepinfo: TExcepInfo; var puArgErr: Integer): HResult; virtual; cdecl; export; abstract;
end;
function DispInvoke(_this: Pointer; ptinfo: ITypeInfo; dispidMember: TDispID;
wFlags: Word; var pparams: TDispParams; pvarResult: PVARIANT;
var pexcepinfo: TExcepInfo; var puArgErr: 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;
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -