1 /******************************************************************************
2 *
3 * Copyright (C) 2004-2008, The Gentee Group. All rights reserved.
4 * This file is part of the Gentee open source project - http://www.gentee.com.
5 *
6 * THIS FILE IS PROVIDED UNDER THE TERMS OF THE GENTEE LICENSE ("AGREEMENT").
7 * ANY USE, REPRODUCTION OR DISTRIBUTION OF THIS FILE CONSTITUTES RECIPIENTS
8 * ACCEPTANCE OF THE AGREEMENT.
9 *
10 * Author: Alexander Krivonogov ( algen )
11 *
12 ******************************************************************************/
13
14 /*-----------------------------------------------------------------------------
15 * Id: comole L "COM/OLE"
16 *
17 * Summary: Working with COM/OLE Object. The COM library is applied for working
18 with the #b(COM/OLE objects), the #b(IDispatch) interface and
19 maintains late binding operations. For using this library, it is
20 required to specify the file olecom.g (from lib\olecom subfolder)
21 with include command. #srcg[
22 |include : $"...\gentee\lib\olecom\olecom.g"]
23 *
24 * List: *,olecom_desc,tvariant,
25 *#lng/opers#,typevar_opeq,variant_opeq,type_opvar,
26 *#lng/methods#,oleobj_createobj,oleobj_getres,oleobj_iserr,
27 oleobj_release,
28 *VARIANT Methods,variant_arrcreate,variant_arrfromg,variant_arrgetptr,
29 variant_clear,variant_ismissing,variant_isnull,variant_setmissing
30 *
31 -----------------------------------------------------------------------------*/
32
33 define <export> {
34 FOLEOBJ_INT = 0x01 // Представлять целые числа uint как int
35 }
36 type oleobj
37 {
38 uint ppv
39 uint flgdotcreate
40 uint pflgs
41 uint err
42 uint perrfunc
43 }
44
45 include {"variant.g"
46 }
47
48 import "Ole32.dll"
49 {
50 uint CoInitializeEx( uint, uint )
51 //uint CoInitialize( uint )
52 CoUninitialize()
53 uint CoGetClassObject( uint, uint, uint, uint, uint )
54 //uint CoCreateInstance( uint, uint, uint, uint, uint )
55 //uint CoCreateInstanceEx( uint, uint, uint, uint, uint, uint )
56 uint CLSIDFromString( uint, uint )
57 uint CLSIDFromProgID( uint, uint )
58 }
59
60 type olecom
61 {
62 uint flginit
63 uint lasterr
64 }
65
66 global {
67 uint oleinit
68 buf IDispatch = '\h00 04 02 00 00 00 00 00 c0 00 00 00 00 00 00 46'
69 buf IClassFactory = '\h01 00 00 00 00 00 00 00 c0 00 00 00 00 00 00 46'
70 buf INULL = '\h00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00'
71 olecom ole
72 }
73
74 define {
75 // COM initialization flags; passed to CoInitialize.
76 COINIT_APARTMENTTHREADED = 0x2 // Apartment model
77 COINIT_MULTITHREADED = 0x0 // OLE calls objects on any thread.
78 COINIT_DISABLE_OLE1DDE = 0x4 // Don't use DDE for Ole1 support.
79 COINIT_SPEED_OVER_MEMORY = 0x8 // Trade memory for speed.
80
81 CLSCTX_INPROC_SERVER = 0x1
82 CLSCTX_INPROC_HANDLER = 0x2
83 CLSCTX_LOCAL_SERVER = 0x4
84 CLSCTX_INPROC_SERVER16 = 0x8
85 CLSCTX_REMOTE_SERVER = 0x10
86 CLSCTX_INPROC_HANDLER16 = 0x20
87 CLSCTX_INPROC_SERVERX86 = 0x40
88 CLSCTX_INPROC_HANDLERX86= 0x80
89 CLSCTX_ESERVER_HANDLER = 0x100
90
91 DISPATCH_METHOD =0x1
92 DISPATCH_PROPERTYGET =0x2
93 DISPATCH_PROPERTYPUT =0x4
94 DISPATCH_PROPERTYPUTREF =0x8
95 }
96
97 type COSERVERINFO
98 {
99 uint dwReserved1
100 uint pwszName
101 uint pAuthInfo
102 uint dwReserved2
103 }
104
105 method olecom.seterr( uint err )
106 {
107 this.lasterr = err
108 }
109
110 func uint olecheck( uint errcode )
111 {
112 uint ret = ? ( errcode & 0x80000000, 0, 1 )
113 if !ret
114 {
115 //print( hex2stru("Ole error [", errcode ) + "]\n" )
116 ole.seterr( errcode )
117 }
118 return ret
119 }
120
121 method olecom.init()
122 {
123 if !this.flginit && olecheck( CoInitializeEx( 0,
124 $COINIT_APARTMENTTHREADED ) )
125 {
126 this.flginit = 1
127 }
128 }
129
130 method olecom.release
131 {
132 if this.flginit
133 {
134 CoUninitialize()
135 this.flginit = 0
136 }
137 }
138
139 method uint olecom.geterr()
140 {
141 return this.lasterr
142 }
143
144 method olecom.noerr()
145 {
146 this.lasterr = 0
147 }
148
149 method olecom.delete()
150 {
151 this.release()
152 }
153
154 /*-----------------------------------------------------------------------------
155 * Id: oleobj_release F3
156 *
157 * Summary: Releasing the COM object. The method deletes the bond between the
158 variable and the COM object and releases the COM object.
159 *
160 -----------------------------------------------------------------------------*/
161
162 method oleobj.release()
163 {
164 if this.ppv
165 {
166 ((this.ppv->uint+8)->uint)->stdcall(this.ppv)
167 //this.flgcreate = 0
168 this.ppv = 0
169 //oleinit--
170 //if !oleinit : CoUninitialize()
171 }
172 }
173
174 property oleobj.errfunc( uint val )
175 {
176 this.perrfunc = val
177 }
178
179 method uint oleobj.check( uint rcode )
180 {
181 this.err = rcode
182 if olecheck( rcode )
183 {
184 return 1
185 }
186 if this.perrfunc
187 {
188 this.perrfunc->func( rcode )
189 }
190 return 0
191 }
192
193 /*-----------------------------------------------------------------------------
194 * Id: oleobj_iserr F3
195 *
196 * Summary: Enables to define whether or not an error occurs while working
197 with a COM object.
198 *
199 * Return: Returns the HRESULT code of the last COM object operation.
200 *
201 -----------------------------------------------------------------------------*/
202
203 method uint oleobj.iserr()
204 {
205 return olecheck( this.err )
206 }
207
208 /*-----------------------------------------------------------------------------
209 * Id: oleobj_getres F3
210 *
211 * Summary: Result of the last operation. This method is applied for getting
212 an error code or a warning; the code is the C type of HRESULT.
213 *
214 * Return: Returns the HRESULT code of the last COM object operation.
215 *
216 -----------------------------------------------------------------------------*/
217
218 method uint oleobj.getres()
219 {
220 return this.err
221 }
222
223 /*-----------------------------------------------------------------------------
224 * Id: oleobj_createobj F2
225 *
226 * Summary: The method creates a new COM object. Example: #srcg[
227 |oleobj excapp
228 |excapp.createobj( "Excel.Application", "" )
229 |//is equal to excapp.createobj( "{00024500-0000-0000-C000-000000000046}", "" ) |
230 |excapp.flgs = $FOLEOBJ_INT
231 |excapp~Visible = 1]
232 *
233 * Params: name - An object name, or the string representation of an object /
234 identifier - "{...}".
235 mashine - A computer name where the required object is created; /
236 if the current string is empty, the object is created /
237 in the current computer.
238 *
239 * Return: #lng/retf#
240 *
241 -----------------------------------------------------------------------------*/
242
243 method uint oleobj.createobj( str name, str mashine )
244 {
245 uint res
246 uint pcf
247 buf iid
248 buf un
249 COSERVERINFO csi
250
251 iid.expand(16)
252 if ole.flginit
253 {
254 this.release()
255
256 res = this.check( CLSIDFromString( un.unicode( name ).ptr(), iid.ptr() ))
257 // res = this.check( CLSIDFromString( un.unicode( name ).ptr(), iid.ptr() ))
258
259 if res
260 {
261 if &mashine
262 {
263 csi.pwszName = un.unicode( mashine ).ptr()
264 }
265 res = this.check( CoGetClassObject(
266 iid.ptr(),
267 ?(&mashine && *mashine, $CLSCTX_REMOTE_SERVER,
268 $CLSCTX_LOCAL_SERVER | $CLSCTX_INPROC_SERVER ),
269 ?(&mashine,&csi,0),
270 IClassFactory.ptr(),
271 &pcf))
272 if res
273 {
274 // print( "x \( ((pcf->uint + 12 )->uint )), \(pcf),
275 // \(IDispatch.ptr()), \( &this.ppv) \n " )
276 res = this.check( ((pcf->uint + 12 )->uint)->stdcall(
277 pcf, 0, IDispatch.ptr(), &this.ppv ))
278 // print( "9\n" )
279 }
280
281 if pcf : ((pcf->uint + 8)->uint)->stdcall( pcf );
282
283 /*olecheck( CoCreateInstance( iid.ptr(), 0,
284 $CLSCTX_LOCAL_SERVER | $CLSCTX_INPROC_SERVER,
285 IDispatch.ptr(), &this.ppv ))*/
286 //if res : this.flgcreate = 1
287 }
288 }
289 return res
290 }
291
292 /*-----------------------------------------------------------------------------
293 * Id: typevar_opeq_1 FC
294 *
295 * Summary: Assign operation. #b[oleobj = VARIANT( VT_DISPATCH )].
296 *
297 * Return: The result #b(oleobj).
298 *
299 -----------------------------------------------------------------------------*/
300
301 operator oleobj = (oleobj left, VARIANT right )
302 {
303 left.release()
304 if (right.vt & $VT_TYPEMASK) == $VT_DISPATCH
305 {
306 left.ppv = uint(right.val)
307 ((uint(left.ppv)->uint+4)->uint)->stdcall(uint(left.ppv))
308 //right.vt = 0
309 uint parent = (&right.val + 4)->uint
310 if parent
311 {
312 left.perrfunc = parent->oleobj.perrfunc
313 left.pflgs = parent->oleobj.pflgs
314 }
315 }
316 return left
317 }
318
319 method oleobj.delete()
320 {
321 this.release()
322 }
323
324 property uint oleobj.flgs()
325 {
326 return this.pflgs
327 }
328
329 property oleobj.flgs( uint val )
330 {
331 this.pflgs = val
332 }
333
334 method uint oleobj.dispatch ( str name, uint typeres,
335 uint addrres, collection pars)
336 {
337 buf un
338 int i, j
339 uint pname = un.unicode(name).ptr()
340 uint idmeth
341 uint typecall
342 int cargs
343 uint dispidnamedargs = -3
344 DISPPARAMS dp
345 VARIANT vres
346 arr varg of VARIANT
347
348 //Получаем код метода
349 if !this.ppv || !this.check( ((this.ppv->uint+20)->uint)->stdcall(
350 this.ppv, INULL.ptr(), &pname, 1, 0x00010000, &idmeth) )
351 {
352 return 0
353 }
354
355 //Формируем параметры
356 if &pars : cargs = *pars
357
358 varg.expand( cargs )
359 if !typeres && addrres == -1
360 {
361 dp.cNamedArgs = 1
362 typecall = $DISPATCH_PROPERTYPUT
363 }
364 else
365 {
366 typecall = $DISPATCH_METHOD
367 if addrres : typecall |= $DISPATCH_PROPERTYGET
368 }
369
370 for i = cargs-1, i >= 0, i--
371 {
372 uint gtype = pars.gettype(i)
373 if this.pflgs & $FOLEOBJ_INT
374 {
375 if gtype == uint : gtype = int
376 }
377 varg[j++].fromg( gtype, ?( gtype <= double, pars.ptr(i),
378 pars.ptr(i)->uint ))
379 }
380
381 dp.rgvarg = varg.ptr()
382 dp.rgdispidNamedArgs = &dispidnamedargs
383 dp.cArgs = cargs
384 //Вызываем метод
385 if !this.check((this.ppv->uint+24)->uint->stdcall( this.ppv, idmeth,
386 INULL.ptr(), 0, typecall, &dp, vres, 0, 0 ))
387 {
388 return 0
389 }
390 //Обрабатываем результаты
391 if addrres && typeres == VARIANT
392 {
393 addrres->VARIANT.vt = vres.vt
394 addrres->VARIANT.val = vres.val
395 if (vres.vt & $VT_TYPEMASK) == $VT_DISPATCH
396 {
397 (&addrres->VARIANT.val + 4)->uint = &this
398 }
399 }
400 vres.vt = 0
401 if this.flgdotcreate
402 {
403 destroy( &this )
404 }
405 return 1
406 }
407
408 method oleobj.call( collection pars, str name )
409 {
410 // print( "CALL \(name)\n" )
411 this.dispatch( name, 0, 0, pars )
412 }
413
414 method oleobj.setval( collection pars, str name )
415 {
416 //print( "SETVAL \(name)\n" )
417 this.dispatch( name, 0, -1, pars )
418 }
419
420 method VARIANT oleobj.getval <result> ( collection pars, str name )
421 {
422 //print( "GETVAL \(name)\n" )
423 this.dispatch( name, VARIANT, &result, pars )
424 }
425
426 method oleobj oleobj.getobj ( collection pars, str name )
427 {
428 uint res
429 VARIANT vres
430 //print( "GETOBJ \(name)\n" )
431 res as new( oleobj )->oleobj
432 this.dispatch( name, VARIANT, &vres, pars )
433 res = vres
434 res.flgdotcreate = 1
435 res.pflgs = this.pflgs
436 res.perrfunc = this.perrfunc
437
438 return res
439 }
440
441 /* property oleboj.valset ()
442 {
443 }*/
444 func err( uint errcode )
445 {
446 print( "Ole error ["+ hex2stru( errcode ) + "]\n" )
447 }
448
449
450 /*-----------------------------------------------------------------------------
451 * Id: olecom_desc F1
452 *
453 * Summary: A brief description of COM/OLE library. This library also contains
454 the support of the #a(tvariant,VARIANT) type, used for data
455 transmitting from/to COM objects.
456
457 Variables of the #b(oleobj) type are used for working with the COM
458 objects; furthermore, each variable of this type has one appropriate
459 COM object. A COM objects method is called with the help of
460 the #a( lateoper, ~ late) binding operation. There are two ways of
461 binding a COM object with a variable , as follows:
462 #p[
463 1. The #a(oleobj_createobj) method is used for creating a new COM object:
464 #srcg[
465 |oleobj excapp
466 |excapp.createobj( "Excel.Application", "" )]]
467
468 #p[2. Binding a variable with the existing COM object (child) is returned by
469 another COM object method call:#srcg[
470 |oleobj workbooks
471 |workbooks = excapp~WorkBooks]]
472
473 #p[The #b(oleobj) object can maintain the following kinds of late binding:]
474 #ul[
475 |elementary method call #b(excapp~Quit), with/without parameters;
476 |set value #b[excapp~Cells( 3, 2 ) = "Hello World!"];
477 |get value #b[vis = uint( excapp~Visible )];
478 call chain #b(excapp~WorkBooks~Add), equals the following expressions
479 ]
480 #srcg[
481 |oleobj workbooks
482 |workbooks = excapp~WorkBooks
483 |workbooks~Add]
484
485 #p[The method call can return only the #b(VARIANT) type, and the appropriate
486 assignment operators and type cast operators are used to convert data to
487 basic Gentee types. Parameters of the COM objects methods call as well as
488 the assigned values are automatically converted to the appropriate VARIANT
489 types. The following Gentee types can be used - #b('uint, int, ulong, long,
490 float, double, str, VARIANT').]
491
492 #p[Use the #a(oleobj_release) method in order to release the COM object;
493 otherwise, the COM object is released when the variable is deleted; also
494 the object is released when the variable is bound with another COM object.
495 Have a look at the example of using the COM object]
496 #srcg[
497 |include : $"...\olecom.g"
498 |func ole_example
499 |{
500 | oleobj excapp
501 | excapp.createobj( "Excel.Application", "" )
502 | excapp.flgs = $FOLEOBJ_INT
503 | excapp~Visible = 1
504 | excapp~WorkBooks~Add
505 | excapp~Cells( 3, 2 ) = "Hello World!"
506 }]
507 #p[The oleobj object has properties, as follows:]
508 #ul[
509 uint #b(flgs) are flags. Flags value can be set or obtained; the property can
510 contain the #b($FOLEOBJ_INT) flag, i.e. when transmitting data to the COM
511 object the unsigned Gentee type of uint is automatically converted to the
512 | signed type of VARIANT( VT_I4 )
513 uint #b(errfunc) is an error handling function. A function address can be
514 assigned to this property, so using the COM object this function will be
515 called as long as an error occurs; furthermore, this function must have
516 a parameter of the uint type, that contains an error code.
517 ]
518 #p[All child objects automatically inherit the #b(flgs) property as well as
519 the #b(errfunc) property.]
520 *
521 * Title: COM/OLE description
522 *
523 * Define:
524 *
525 -----------------------------------------------------------------------------*/
526
527 //----------------------------------------------------------------------------
528
529 /*-----------------------------------------------------------------------------
530 ** Id: tvariant F1
531 *
532 * Summary: VARIANT type. #b(VARIANT) is a universal type that is used for
533 storing various data and it enables different programs to exchange data
534 properly. This type represents a structure consisted of two main fields:
535 the first field is a type of the stored value, the second field is the
536 stored value or the pointer to a storage area. The #b(VARIANT) type is
537 defined as follows:
538 #srcg[
539 |type VARIANT {
540 | ushort vt
541 | ushort wReserved1
542 | ushort wReserved2
543 | ushort wReserved3
544 | ulong val
545 }]
546 #p[
547 #b(vt) is a type code of the contained value ( type constants VT_*: $VT_UI4, $VT_I4, $VT_BSTR ... );#br#
548 #b(val) is a field used for storing values]
549 #p[
550 The library provides only some of the operations of the VARIANT type, however, you can use the fields of the given structure.
551 The example illustrates creation of the VARIANT( VT_BOOL ) variable:]
552 #srcg[
553 |VARIANT bool
554 |....
555 |bool.clear()
556 |bool.vt = $VT_BOOL
557 |(&bool.val)->uint = 0xffff// 0xffff - VARIANT_TRUE]
558
559 #p[This example shows VARIANT operations]
560 #srcg[
561 |uint val
562 |str res
563 |oleobj ActWorkSheet
564 |VARIANT vval
565 |
566 |....
567 |vval = int( 100 ) //VARIANT( VT_I4 ) is being created
568 |excapp~Cells(1,1) = vval //equals excapp~Cells(1,1) = 100
569 |
570 |vval = "Test string" //VARIANT( VT_BSTR ) is being created
571 |excapp~Cells(2,1) = vval //equals excapp~Cells(1,1) = "Test string"
572 |
573 |val = uint( excapp~Cells(1,1)~Value ) //VARIANT( VT_I4 ) is converted to uint
574 |res = excapp~Cells(2,1)~Value //VARIANT( VT_BSTR ) is converted to str
575 |ActWorkSheet = excapp~ActiveWorkSheet //VARIANT( VT_DISPATCH ) is converted
576 to oleobj]
577 *
578 * Title: VARIANT
579 *
580 * Define:
581 *
582 -----------------------------------------------------------------------------*/
583
584 //----------------------------------------------------------------------------
585
586 /*v1.arrcreate( $VT_VARIANT, %{3,0,2,0} )
587
588 v1.arrfromg( %{0,0, 0.0001f} )
589 b++
590 v1.arrfromg( %{0,1, b++} )
591 v1.arrfromg( %{1,0, b++} )
592 v1.arrfromg( %{1,1, b++} )
593 v1.arrfromg( %{2,0, b++} )
594 v1.arrfromg( %{2,1, b} )
595 exc_app.errfunc = &err*/
596 /*func a <main>
597 {
598 oleobj exc
599
600
601 // exc.createobj( "Excel.Application", "" )
602 if ( !exc.createobj( "{00024500-0000-0000-C000-000000000046}", "" ) )
603 {
604 print("error\n" )
605 }
606 exc.flgs = $FOLEOBJ_INT
607 exc~Visible = 1
608 exc~WorkBooks~Add
609 VARIANT v
610 v.arrcreate( %{3,0,2,0} )//Создается массив с 3-мя строками и 2-мя столбцами
611
612 v.arrfromg( %{0,0, 0.1234f} )
613 v.arrfromg( %{0,1, int(100)} )
614 v.arrfromg( %{2,1, "Testsssssssss" } )
615 exc~Range( exc~Cells( 1, 1 ), exc~Cells( 3, 2 ) ) = v //Передача массива в COM объект
616
617 print( "ok\n" )
618 getch()
619 //exc~Quit
620 }*/
621