1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
|
{
This file is part of the Free Pascal run time library.
Copyright (c) 2006 by Florian Klaempfl
member of the Free Pascal development team.
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
**********************************************************************}
{$mode objfpc}
{$H+}
{$inline on}
unit mcomobj;
interface
{ $define DEBUG_COM}
uses
Windows,Sysutils,classes;
const
CLSCTX_INPROC_SERVER = $0001; // server dll (runs in same process as caller)
CLSCTX_INPROC_HANDLER = $0002; // handler dll (runs in same process as caller)
CLSCTX_LOCAL_SERVER = $0004; // server exe (runs on same machine; diff proc)
CLSCTX_INPROC_SERVER16 = $0008; // 16-bit server dll (runs in same process as caller)
CLSCTX_REMOTE_SERVER = $0010; // remote server exe (runs on different machine)
CLSCTX_INPROC_HANDLER16 = $0020; // 16-bit handler dll (runs in same process as caller)
CLSCTX_INPROC_SERVERX86 = $0040; // Wx86 server dll (runs in same process as caller)
CLSCTX_INPROC_HANDLERX86 = $0080; // Wx86 handler dll (runs in same process as caller)
CLSCTX_ESERVER_HANDLER = $0100; // handler dll (runs in the server process)
CLSCTX_RESERVED =$0200; // reserved
CLSCTX_NO_CODE_DOWNLOAD = $0400; // disallow code download from the Directory Service (if any) or the internet -rahulth
CLSCTX_NO_WX86_TRANSLATION = $0800;
CLSCTX_NO_CUSTOM_MARSHAL = $1000;
CLSCTX_ENABLE_CODE_DOWNLOAD = $2000; // allow code download from the Directory Service (if any) or the internet
CLSCTX_NO_FAILURE_LOG = $04000; // do not log messages about activation failure (should one occur) to Event Log
CLSCTX_DISABLE_AAA = $08000; // Disable EOAC_DISABLE_AAA capability for this activation only
CLSCTX_ENABLE_AAA = $10000; // Enable EOAC_DISABLE_AAA capability for this activation only
CLSCTX_FROM_DEFAULT_CONTEXT = $20000; // Begin this activation from the default context of the current apartment
CLSCTX_INPROC = (CLSCTX_INPROC_SERVER OR CLSCTX_INPROC_HANDLER);
CLSCTX_ALL = (CLSCTX_INPROC_SERVER OR CLSCTX_INPROC_HANDLER OR CLSCTX_LOCAL_SERVER {$ifdef Remote} OR CLSCTX_REMOTE_SERVER {$endif});
CLSCTX_SERVER = (CLSCTX_INPROC_SERVER OR CLSCTX_LOCAL_SERVER {$ifdef Remote} OR CLSCTX_REMOTE_SERVER {$endif});
MEMCTX_TASK = 1; // task (private) memory
MEMCTX_SHARED = 2; // shared memory (between processes)
MEMCTX_MACSYSTEM = 3; // on the mac, the system heap
// these are mostly for internal use...
MEMCTX_UNKNOWN = -1; // unknown context (when asked about it)
MEMCTX_SAME = -2; // same context (as some other pointer)
type
TOleChar = WideChar;
POleStr = PWideChar;
PPOleStr = ^POleStr;
OleChar = WChar;
LPOLESTR = ^OLECHAR;
POLECHAR = LPOLESTR;
PLPOLESTR = ^LPOLESTR;
TClassInstancing = (ciInternal, ciSingleInstance, ciMultiInstance);
TThreadingModel = (tmSingle, tmApartment, tmFree, tmBoth, tmNeutral);
type
EOleError = class(Exception);
EOleSysError = class(EOleError)
private
FErrorCode: HRESULT;
public
constructor Create(const Msg: string; aErrorCode: HRESULT;aHelpContext: Integer);
property ErrorCode: HRESULT read FErrorCode write FErrorCode;
end;
function CreateComObject(const ClassID: TGUID) : IUnknown;
function CreateOleObject(const ClassName : string) : IDispatch;
function GetActiveOleObject(const ClassName: string) : IDispatch;
procedure OleCheck(Value : HResult);inline;
procedure OleError(Code: HResult);
function ProgIDToClassID(const id : string) : TGUID;
function ClassIDToProgID(const classID: TGUID): string;
type
TCoInitializeExProc = function (pvReserved: Pointer;
coInit: DWORD): HResult; stdcall;
TCoAddRefServerProcessProc = function : ULONG; stdcall;
TCoReleaseServerProcessProc = function : ULONG; stdcall;
TCoResumeClassObjectsProc = function : HResult; stdcall;
TCoSuspendClassObjectsProc = function : HResult; stdcall;
_COSERVERINFO = Record
dwReserved1 : DWord;
pwszName : LPWSTR;
pAuthInfo : Pointer;
dwReserved2 : DWord;
end;
TCOSERVERINFO = _COSERVERINFO;
PCOSERVERINFO = ^TCOSERVERINFO;
IMalloc = Interface(IUnknown)
['{00000002-0000-0000-C000-000000000046}']
Function Alloc(cb :size_t):Pointer; Stdcall;
Function Realloc (pv :pointer;cb:size_t):Pointer;stdcall;
Procedure Free({[in]} pv: pointer); Stdcall;
Function GetSize(pv:pointer):size_t;stdcall;
Function DidAlloc(pv:pointer):Longint;stdcall;
procedure HeapMinimize; stdcall;
End;
const
CoInitializeEx : TCoInitializeExProc = nil;
CoAddRefServerProcess : TCoAddRefServerProcessProc = nil;
CoReleaseServerProcess : TCoReleaseServerProcessProc = nil;
CoResumeClassObjects : TCoResumeClassObjectsProc = nil;
CoSuspendClassObjects : TCoSuspendClassObjectsProc = nil;
CoInitFlags : Longint = -1;
function CLSIDFromProgID(_para1:POLESTR; _para2:LPCLSID):HRESULT;stdcall; external 'ole32.dll' name 'CLSIDFromProgID';
function CLSIDFromProgID(_para1:POLESTR; out _para2:TCLSID):HRESULT;stdcall; external 'ole32.dll' name 'CLSIDFromProgID';
function CoInitialize(_para1:PVOID):HRESULT;stdcall; external 'ole32.dll' name 'CoInitialize';
function CoCreateInstance(const _para1:TCLSID; _para2:IUnknown; _para3:DWORD;const _para4:TIID;out _para5):HRESULT;stdcall; external 'ole32.dll' name 'CoCreateInstance';
function GetActiveObject(const clsid: TCLSID; pvReserved: Pointer; out unk: IUnknown) : HResult; stdcall; external 'oleaut32.dll' name 'GetActiveObject';
function ProgIDFromCLSID(para:PCLSID; out _para2:POLESTR):HRESULT;stdcall; external 'ole32.dll' name 'ProgIDFromCLSID';
function ProgIDFromCLSID(const _para1:TCLSID; out _para2:POLESTR):HRESULT;stdcall; external 'ole32.dll' name 'ProgIDFromCLSID';
procedure CoTaskMemFree(_para1:PVOID);stdcall; external 'ole32.dll' name 'CoTaskMemFree';
function CoGetMalloc(_para1:DWORD; out _para2:IMalloc):HRESULT;stdcall; external 'ole32.dll' name 'CoGetMalloc';
procedure CoUninitialize;stdcall; external 'ole32.dll' name 'CoUninitialize';
function CoCreateGuid(out _para1:TGUID):HRESULT;stdcall;external 'ole32.dll' name 'CoCreateGuid';
function StringFromCLSID(const _para1:TCLSID; out _para2:POLESTR):HRESULT;stdcall; external 'ole32.dll' name 'StringFromCLSID';
implementation
uses
ComConst, Ole2, RtlConsts;
constructor EOleSysError.Create(const Msg: string; aErrorCode: HRESULT; aHelpContext: Integer);
var
m : string;
begin
if Msg='' then
m:=SysErrorMessage(aErrorCode)
else
m:=Msg;
inherited CreateHelp(m,HelpContext);
FErrorCode:=aErrorCode;
end;
{$define FPC_COMOBJ_HAS_CREATE_CLASS_ID}
function CreateClassID : ansistring;
var
ClassID : TCLSID;
p : PWideChar;
begin
CoCreateGuid(ClassID);
StringFromCLSID(ClassID,p);
result:=p;
CoTaskMemFree(p);
end;
function CreateComObject(const ClassID : TGUID) : IUnknown;
begin
OleCheck(CoCreateInstance(ClassID,nil,CLSCTX_INPROC_SERVER or CLSCTX_LOCAL_SERVER,IUnknown,result));
end;
function CreateOleObject(const ClassName : string) : IDispatch;
var
id : TCLSID;
begin
id:=ProgIDToClassID(ClassName);
OleCheck(CoCreateInstance(id,nil,CLSCTX_INPROC_SERVER or CLSCTX_LOCAL_SERVER,IDispatch,result));
end;
function GetActiveOleObject(const ClassName : string) : IDispatch;
{$ifndef wince}
var
intf : IUnknown;
id : TCLSID;
begin
id:=ProgIDToClassID(ClassName);
OleCheck(GetActiveObject(id,nil,intf));
OleCheck(intf.QueryInterface(IDispatch,Result));
end;
{$else}
begin
Result:=nil;
end;
{$endif wince}
procedure OleError(Code: HResult);
begin
raise EOleSysError.Create('',Code,0);
end;
procedure OleCheck(Value : HResult);inline;
begin
if not(Succeeded(Value)) then
OleError(Value);
end;
function ProgIDToClassID(const id : string) : TGUID;
begin
OleCheck(CLSIDFromProgID(PWideChar(WideString(id)),result));
end;
function ClassIDToProgID(const classID: TGUID): string;
var
progid : LPOLESTR;
begin
OleCheck(ProgIDFromCLSID(@classID,progid));
result:=progid;
CoTaskMemFree(progid);
end;
const
Initialized : boolean = false;
var
Ole32Dll : HModule;
initialization
Ole32Dll:=GetModuleHandle('ole32.dll');
if Ole32Dll<>0 then
begin
Pointer(CoInitializeEx):=GetProcAddress(Ole32Dll,'CoInitializeEx');
Pointer(CoAddRefServerProcess):=GetProcAddress(Ole32Dll,'CoAddRefServerProcess');
Pointer(CoReleaseServerProcess):=GetProcAddress(Ole32Dll,'CoReleaseServerProcess');
Pointer(CoResumeClassObjects):=GetProcAddress(Ole32Dll,'CoResumeClassObjects');
Pointer(CoSuspendClassObjects):=GetProcAddress(Ole32Dll,'CoSuspendClassObjects');
end;
if not(IsLibrary) then
{$ifndef wince}
if (CoInitFlags=-1) or not(assigned(mcomobj.CoInitializeEx)) then
Initialized:=Succeeded(CoInitialize(nil))
else
{$endif wince}
Initialized:=Succeeded(mcomobj.CoInitializeEx(nil, CoInitFlags));
finalization
if Initialized then
CoUninitialize;
end.
|
