fivedev/harbour-core
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

2009-03-25 13:35 UTC+0200 Mindaugas Kavaliauskas (dbtopas/at/dbtopas.lt)

Browse Source 
- harbour/contrib/hbole/ole2.c
  * harbour/contrib/hbole/oleauto.prg
  + harbour/contrib/hbole/oleinit.c
  + harbour/contrib/hbole/olecore.c
    + added my own implementation of OLE library. It is bases on old 
      code written by Jose F. Gimenez. Code is changed to be reentrant,
      more clean, but only basic features are implemented.
This commit is contained in:
Mindaugas Kavaliauskas
2009-03-25 11:42:18 +00:00
parent 455e6e201f
commit 7f9b899571
6 changed files with 754 additions and 860 deletions
Download Patch File Download Diff File Expand all files Collapse all files

9
harbour/ChangeLog
View File

@@ -8,6 +8,15 @@
2009-12-31 13:59 UTC+0100 Foo Bar (foo.bar foobar.org)
*/
2009-03-25 13:35 UTC+0200 Mindaugas Kavaliauskas (dbtopas/at/dbtopas.lt)
- harbour/contrib/hbole/ole2.c
* harbour/contrib/hbole/oleauto.prg
+ harbour/contrib/hbole/oleinit.c
+ harbour/contrib/hbole/olecore.c
+ added my own implementation of OLE library. It is bases on old
code written by Jose F. Gimenez. Code is changed to be reentrant,
more clean, but only basic features are implemented.
2009-03-25 12:30 UTC+0100 Przemyslaw Czerpak (druzus/at/priv.onet.pl)
* harbour/include/hbstack.h
! disabled inline assembler code to retrieve HVM stack pointer from TLS

3
harbour/contrib/hbole/Makefile
View File

@@ -9,7 +9,8 @@ LIBNAME=hbole
ifeq ($(HB_ARCHITECTURE),win)
C_SOURCES=\
ole2.c \
oleinit.c \
olecore.c \
PRG_SOURCES=\
oleauto.prg \

665
harbour/contrib/hbole/ole2.c
View File

@@ -1,665 +0,0 @@
/*
* $Id$
*/
/*
* Harbour Project source code:
* OLE library
*
* Copyright 2000,2003 Jose F. Gimenez (JFG) <jfgimenez@wanadoo.es>
* www - http://www.harbour-project.org
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2, or (at your option)
* any later version.
*
* 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. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this software; see the file COPYING. If not, write to
* the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA (or visit the web site http://www.gnu.org/).
*
* As a special exception, the Harbour Project gives permission for
* additional uses of the text contained in its release of Harbour.
*
* The exception is that, if you link the Harbour libraries with other
* files to produce an executable, this does not by itself cause the
* resulting executable to be covered by the GNU General Public License.
* Your use of that executable is in no way restricted on account of
* linking the Harbour library code into it.
*
* This exception does not however invalidate any other reasons why
* the executable file might be covered by the GNU General Public License.
*
* This exception applies only to the code released by the Harbour
* Project under the name Harbour. If you copy code from other
* Harbour Project or Free Software Foundation releases into a copy of
* Harbour, as the General Public License permits, the exception does
* not apply to the code that you add in this way. To avoid misleading
* anyone as to the status of such modified files, you must delete
* this exception notice from them.
*
* If you write modifications of your own for Harbour, it is your choice
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice.
*
*/
/*************************************************************************
* *
* CreateOleObject( cOleName | cCLSID [, cIID ] ) -> hOleObject *
* *
* OleInvoke( hOleObject, cMethodName, uParam1, ..., uParamN ) *
* -> uResult *
* *
* OleSetProperty( hOleObject, cPropertyName, uParam1, ..., uParamN ) *
* -> lOk *
* *
* OleGetProperty( hOleObject, cPropertyName, uParam1, ..., uParamN ) *
* -> uResult *
* *
* OleIsObject() -> lIsObject *
* *
* OleError() -> nError *
* *
* Ole2TxtError() -> cError *
* *
* OleUninitialize() -> Nil *
* *
\************************************************************************/
#define HB_OS_WIN_USED
#ifndef CINTERFACE
#define CINTERFACE 1
#endif
#define NONAMELESSUNION
#if defined( __cplusplus ) && ( defined( __BORLANDC__ ) || defined( _MSC_VER ) || ( defined(__WATCOMC__) && ( __WATCOMC__ >= 1280 ) ) )
# define HB_ID_REF( type, id ) id
#else
# define HB_ID_REF( type, id ) ( ( type ) &id )
#endif
#include "hbvm.h"
#include "hbapiitm.h"
#include "hbapicls.h"
#include "hbdate.h"
#include <ole2.h>
static VARIANTARG s_RetVal;
static EXCEPINFO s_excep;
static HRESULT s_nOleError = 0;
static int s_bInitialized = FALSE;
static double DateToDbl( LPSTR cDate )
{
return hb_dateEncStr( cDate ) - 0x0024d9abL;
}
static LPSTR DblToDate( double nDate, char * cDate )
{
hb_dateDecStr( cDate, ( long ) nDate + 0x0024d9abL );
return cDate;
}
static LPWSTR AnsiToWide( LPCSTR cAnsi )
{
unsigned int wLen;
LPWSTR cString;
wLen = MultiByteToWideChar( CP_ACP, MB_PRECOMPOSED, cAnsi, -1, 0, 0 );
cString = ( LPWSTR ) hb_xgrab( wLen * 2 );
MultiByteToWideChar( CP_ACP, MB_PRECOMPOSED, cAnsi, -1,
( LPWSTR ) cString, wLen );
return cString;
}
static LPSTR WideToAnsi( LPWSTR cWide )
{
unsigned int wLen;
LPSTR cString;
wLen = WideCharToMultiByte( CP_ACP, 0, ( LPWSTR ) cWide, -1,
NULL, 0, NULL, NULL );
cString = ( LPSTR ) hb_xgrab( wLen ? wLen : 2 );
WideCharToMultiByte( CP_ACP, 0, ( LPWSTR ) cWide, -1,
cString, wLen, NULL, NULL );
return cString;
}
static void GetParams( DISPPARAMS * dParams )
{
VARIANTARG * pArgs = NULL;
int n, nArgs, nArg;
nArgs = hb_pcount() - 2;
if( nArgs > 0 )
{
pArgs = ( VARIANTARG * ) hb_xgrab( sizeof( VARIANTARG ) * nArgs );
for( n = 0; n < nArgs; n++ )
{
PHB_ITEM uParam;
/* Los parametros en VARIANTARG[] hay que ponerlos en orden inverso */
nArg = nArgs + 2 - n;
VariantInit( &( pArgs[ n ] ) );
uParam = hb_param( nArg, 0xFFFF );
switch( hb_itemType( uParam ) )
{
case '\0':
#if !defined(__BORLANDC__) && !defined(__XCC__) && !defined(NONAMELESSUNION)
pArgs[ n ].vt = VT_EMPTY;
#else
pArgs[ n ].n1.n2.vt = VT_EMPTY;
#endif
break;
case HB_IT_STRING:
case HB_IT_MEMO:
{
LPWSTR cString;
#if !defined(__BORLANDC__) && !defined(__XCC__) && !defined(NONAMELESSUNION)
pArgs[ n ].vt = VT_BSTR;
#else
pArgs[ n ].n1.n2.vt = VT_BSTR;
#endif
cString = AnsiToWide( hb_parc( nArg ) );
#if !defined(__BORLANDC__) && !defined(__XCC__) && !defined(NONAMELESSUNION)
pArgs[ n ].bstrVal = SysAllocString( ( OLECHAR * ) cString );
#else
pArgs[ n ].n1.n2.n3.bstrVal = SysAllocString( ( OLECHAR * ) cString );
#endif
hb_xfree( cString );
break;
}
case HB_IT_LOGICAL:
#if !defined(__BORLANDC__) && !defined(__XCC__) && !defined(NONAMELESSUNION)
pArgs[ n ].vt = VT_BOOL;
pArgs[ n ].boolVal = hb_parl( nArg ) ? VARIANT_TRUE : VARIANT_FALSE;
#else
pArgs[ n ].n1.n2.vt = VT_BOOL;
pArgs[ n ].n1.n2.n3.boolVal = hb_parl( nArg ) ? VARIANT_TRUE : VARIANT_FALSE;
#endif
break;
case HB_IT_INTEGER:
case HB_IT_LONG:
case HB_IT_NUMERIC:
#if !defined(__BORLANDC__) && !defined(__XCC__) && !defined(NONAMELESSUNION)
pArgs[ n ].vt = VT_I4;
pArgs[ n ].lVal = hb_parnl( nArg );
#else
pArgs[ n ].n1.n2.vt = VT_I4;
pArgs[ n ].n1.n2.n3.lVal = hb_parnl( nArg );
#endif
break;
case HB_IT_DOUBLE:
#if !defined(__BORLANDC__) && !defined(__XCC__) && !defined(NONAMELESSUNION)
pArgs[ n ].vt = VT_R8;
pArgs[ n ].dblVal = hb_parnd( nArg );
#else
pArgs[ n ].n1.n2.vt = VT_R8;
pArgs[ n ].n1.n2.n3.dblVal = hb_parnd( nArg );
#endif
break;
case HB_IT_DATE:
#if !defined(__BORLANDC__) && !defined(__XCC__) && !defined(NONAMELESSUNION)
pArgs[ n ].vt = VT_DATE;
pArgs[ n ].dblVal = DateToDbl( hb_pards( nArg ) );
#else
pArgs[ n ].n1.n2.vt = VT_DATE;
pArgs[ n ].n1.n2.n3.dblVal = DateToDbl( hb_pards( nArg ) );
#endif
break;
case HB_IT_OBJECT:
{
PHB_DYNS pData;
#if !defined(__BORLANDC__) && !defined(__XCC__) && !defined(NONAMELESSUNION)
pArgs[ n ].vt = VT_EMPTY;
#else
pArgs[ n ].n1.n2.vt = VT_EMPTY;
#endif
if( hb_stricmp( hb_objGetClsName( uParam ), "TOleAuto" ) == 0 )
{
pData = hb_dynsymFindName( "hObj" );
if( pData )
{
hb_vmPushDynSym( pData );
hb_vmPush( uParam );
hb_vmDo( 0 );
#if !defined(__BORLANDC__) && !defined(__XCC__) && !defined(NONAMELESSUNION)
pArgs[ n ].vt = VT_DISPATCH;
pArgs[ n ].pdispVal = ( IDispatch * ) hb_parptr( -1 );
#else
pArgs[ n ].n1.n2.vt = VT_DISPATCH;
pArgs[ n ].n1.n2.n3.pdispVal = ( IDispatch * ) hb_parptr( -1 );
#endif
}
}
}
break;
}
}
}
dParams->rgvarg = pArgs;
dParams->cArgs = nArgs;
dParams->rgdispidNamedArgs = 0;
dParams->cNamedArgs = 0;
}
static void FreeParams( DISPPARAMS * dParams )
{
if( dParams->cArgs > 0 )
{
int n;
for( n = 0; n < ( int ) dParams->cArgs; n++ )
VariantClear( &( dParams->rgvarg[ n ] ) );
hb_xfree( ( LPVOID ) dParams->rgvarg );
}
}
static void RetValue( void )
{
#if !defined(__BORLANDC__) && !defined(__XCC__) && !defined(NONAMELESSUNION)
switch( s_RetVal.vt )
{
case VT_BSTR:
hb_retc_buffer( WideToAnsi( ( LPSTR ) s_RetVal.bstrVal ) );
break;
case VT_BOOL:
hb_retl( s_RetVal.boolVal == VARIANT_TRUE );
break;
case VT_DISPATCH:
hb_retptr( s_RetVal.pdispVal );
break;
case VT_I4:
hb_retnl( ( LONG ) s_RetVal.iVal );
break;
case VT_R8:
hb_retnd( s_RetVal.dblVal );
break;
case VT_DATE:
{
char cDate[ 9 ];
hb_retds( DblToDate( s_RetVal.dblVal, cDate ) );
break;
}
case VT_EMPTY:
break;
default:
if( s_nOleError == S_OK )
s_nOleError = ( HRESULT ) -1;
break;
}
if( s_RetVal.vt != VT_DISPATCH )
VariantClear( &s_RetVal );
#else
switch( s_RetVal.n1.n2.vt )
{
case VT_BSTR:
hb_retc_buffer( WideToAnsi( ( LPWSTR ) s_RetVal.n1.n2.n3.bstrVal ) );
break;
case VT_BOOL:
hb_retl( s_RetVal.n1.n2.n3.boolVal == VARIANT_TRUE );
break;
case VT_DISPATCH:
hb_retptr( s_RetVal.n1.n2.n3.pdispVal );
break;
case VT_I4:
hb_retnl( ( LONG ) s_RetVal.n1.n2.n3.iVal );
break;
case VT_R8:
hb_retnd( s_RetVal.n1.n2.n3.dblVal );
break;
case VT_DATE:
{
char cDate[ 9 ];
hb_retds( DblToDate( s_RetVal.n1.n2.n3.dblVal, cDate ) );
break;
}
case VT_EMPTY:
break;
default:
if( s_nOleError == S_OK )
s_nOleError = ( HRESULT ) -1;
break;
}
if( s_RetVal.n1.n2.vt != VT_DISPATCH )
VariantClear( &s_RetVal );
#endif
}
HB_FUNC( CREATEOLEOBJECT ) /* ( cOleName | cCLSID [, cIID ] ) */
{
void * pDisp = NULL; /* IDispatch */
/* 'void *' used intentionally to inform compiler that there is no strict-aliasing */
s_nOleError = S_OK;
if( ! s_bInitialized )
{
s_nOleError = OleInitialize( NULL );
s_bInitialized = TRUE;
}
if( s_nOleError == S_OK ||
s_nOleError == S_FALSE )
{
LPWSTR cCLSID;
GUID ClassID, iid;
LPIID riid = ( LPIID ) &IID_IDispatch;
cCLSID = AnsiToWide( hb_parc( 1 ) );
if( hb_parc( 1 )[ 0 ] == '{' )
s_nOleError = CLSIDFromString( ( LPOLESTR ) cCLSID, ( LPCLSID ) &ClassID );
else
s_nOleError = CLSIDFromProgID( ( LPCOLESTR ) cCLSID, ( LPCLSID ) &ClassID );
hb_xfree( cCLSID );
if( hb_pcount() == 2 )
{
if( hb_parc( 2 )[ 0 ] == '{' )
{
cCLSID = AnsiToWide( hb_parc( 2 ) );
s_nOleError = CLSIDFromString( ( LPOLESTR ) cCLSID, &iid );
hb_xfree( cCLSID );
}
else
memcpy( ( LPVOID ) &iid, hb_parc( 2 ), sizeof( iid ) );
riid = &iid;
}
if( s_nOleError == S_OK )
s_nOleError = CoCreateInstance( HB_ID_REF( REFCLSID, ClassID ), NULL, CLSCTX_SERVER,
(REFIID) riid, &pDisp );
}
hb_retptr( pDisp );
}
static LPSTR hb_oleWideToAnsi( BSTR wString )
{
int nConvertedLen = WideCharToMultiByte( CP_ACP, 0, wString, -1, NULL, 0, NULL, NULL );
if( nConvertedLen )
{
char * cString = ( char * ) hb_xgrab( nConvertedLen + 1 );
if( WideCharToMultiByte( CP_ACP, 0, wString, -1, cString, nConvertedLen + 1, NULL, NULL ) )
return cString;
else
hb_xfree( cString );
}
return NULL;
}
HB_FUNC( OLEEXCEPTIONSOURCE )
{
if( ( LONG ) s_nOleError == DISP_E_EXCEPTION )
hb_retc_buffer( hb_oleWideToAnsi( s_excep.bstrSource ) );
}
HB_FUNC( OLEEXCEPTIONDESCRIPTION )
{
if( ( LONG ) s_nOleError == DISP_E_EXCEPTION )
hb_retc_buffer( hb_oleWideToAnsi( s_excep.bstrDescription ) );
}
HB_FUNC( OLEINVOKE ) /* ( hOleObject, szMethodName, uParams... ) */
{
IDispatch * pDisp = ( IDispatch * ) hb_parptr( 1 );
LPWSTR cMember;
DISPID lDispID;
DISPPARAMS dParams;
UINT uArgErr;
VariantInit( &s_RetVal );
memset( ( LPBYTE ) &s_excep, 0, sizeof( s_excep ) );
cMember = AnsiToWide( hb_parc( 2 ) );
s_nOleError = pDisp->lpVtbl->GetIDsOfNames( pDisp, HB_ID_REF( REFIID, IID_NULL ),
( wchar_t ** ) &cMember, 1,
LOCALE_USER_DEFAULT, &lDispID );
hb_xfree( cMember );
if( s_nOleError == S_OK )
{
GetParams( &dParams );
s_nOleError = pDisp->lpVtbl->Invoke( pDisp,
lDispID,
HB_ID_REF( REFIID, IID_NULL ),
LOCALE_USER_DEFAULT,
DISPATCH_METHOD,
&dParams,
&s_RetVal,
&s_excep,
&uArgErr ) ;
FreeParams( &dParams );
}
RetValue();
}
HB_FUNC( OLESETPROPERTY ) /* ( hOleObject, cPropName, uValue, uParams... ) */
{
IDispatch * pDisp = ( IDispatch * ) hb_parptr( 1 );
LPWSTR cMember;
DISPID lDispID;
DISPID lPropPut = DISPID_PROPERTYPUT;
DISPPARAMS dParams;
UINT uArgErr;
VariantInit( &s_RetVal );
memset( ( LPBYTE ) &s_excep, 0, sizeof( s_excep ) );
cMember = AnsiToWide( hb_parc( 2 ) );
s_nOleError = pDisp->lpVtbl->GetIDsOfNames( pDisp, HB_ID_REF( REFIID, IID_NULL ),
( wchar_t ** ) &cMember, 1,
LOCALE_USER_DEFAULT, &lDispID );
hb_xfree( cMember );
if( s_nOleError == S_OK )
{
GetParams( &dParams );
dParams.rgdispidNamedArgs = &lPropPut;
dParams.cNamedArgs = 1;
s_nOleError = pDisp->lpVtbl->Invoke( pDisp,
lDispID,
HB_ID_REF( REFIID, IID_NULL ),
LOCALE_USER_DEFAULT,
DISPATCH_PROPERTYPUT,
&dParams,
NULL, /* No return value */
&s_excep,
&uArgErr );
FreeParams( &dParams );
}
}
HB_FUNC( OLEGETPROPERTY ) /* ( hOleObject, cPropName, uParams... ) */
{
IDispatch * pDisp = ( IDispatch * ) hb_parptr( 1 );
LPWSTR cMember;
DISPID lDispID;
DISPPARAMS dParams;
UINT uArgErr;
VariantInit( &s_RetVal );
memset( ( LPBYTE ) &s_excep, 0, sizeof( s_excep ) );
cMember = AnsiToWide( hb_parc( 2 ) );
s_nOleError = pDisp->lpVtbl->GetIDsOfNames( pDisp, HB_ID_REF( REFIID, IID_NULL ),
( wchar_t ** ) &cMember, 1,
LOCALE_USER_DEFAULT, &lDispID );
hb_xfree( cMember );
if( s_nOleError == S_OK )
{
GetParams( &dParams );
s_nOleError = pDisp->lpVtbl->Invoke( pDisp,
lDispID,
HB_ID_REF( REFIID, IID_NULL ),
LOCALE_USER_DEFAULT,
DISPATCH_PROPERTYGET,
&dParams,
&s_RetVal,
&s_excep,
&uArgErr );
FreeParams( &dParams );
}
RetValue();
}
HB_FUNC( OLEERROR )
{
hb_retnl( ( long ) s_nOleError );
}
HB_FUNC( OLE2TXTERROR )
{
switch( ( LONG ) s_nOleError )
{
case S_OK: hb_retc( "S_OK" ); break;
case CO_E_CLASSSTRING: hb_retc( "CO_E_CLASSSTRING" ); break;
case OLE_E_WRONGCOMPOBJ: hb_retc( "OLE_E_WRONGCOMPOBJ" ); break;
case REGDB_E_CLASSNOTREG: hb_retc( "REGDB_E_CLASSNOTREG" ); break;
case REGDB_E_WRITEREGDB: hb_retc( "REGDB_E_WRITEREGDB" ); break;
case E_OUTOFMEMORY: hb_retc( "E_OUTOFMEMORY" ); break;
case E_INVALIDARG: hb_retc( "E_INVALIDARG" ); break;
case E_UNEXPECTED: hb_retc( "E_UNEXPECTED" ); break;
case DISP_E_UNKNOWNNAME: hb_retc( "DISP_E_UNKNOWNNAME" ); break;
case DISP_E_UNKNOWNLCID: hb_retc( "DISP_E_UNKNOWNLCID" ); break;
case DISP_E_BADPARAMCOUNT: hb_retc( "DISP_E_BADPARAMCOUNT" ); break;
case DISP_E_BADVARTYPE: hb_retc( "DISP_E_BADVARTYPE" ); break;
case DISP_E_EXCEPTION: hb_retc( "DISP_E_EXCEPTION" ); break;
case DISP_E_MEMBERNOTFOUND: hb_retc( "DISP_E_MEMBERNOTFOUND" ); break;
case DISP_E_NONAMEDARGS: hb_retc( "DISP_E_NONAMEDARGS" ); break;
case DISP_E_OVERFLOW: hb_retc( "DISP_E_OVERFLOW" ); break;
case DISP_E_PARAMNOTFOUND: hb_retc( "DISP_E_PARAMNOTFOUND" ); break;
case DISP_E_TYPEMISMATCH: hb_retc( "DISP_E_TYPEMISMATCH" ); break;
case DISP_E_UNKNOWNINTERFACE: hb_retc( "DISP_E_UNKNOWNINTERFACE" ); break;
case DISP_E_PARAMNOTOPTIONAL: hb_retc( "DISP_E_PARAMNOTOPTIONAL" ); break;
default: hb_retc( "Unknown error" ); break;
}
}
HB_FUNC( OLEISOBJECT )
{
#if !defined(__BORLANDC__) && !defined(__XCC__) && !defined(NONAMELESSUNION)
hb_retl( s_RetVal.vt == VT_DISPATCH );
#else
hb_retl( s_RetVal.n1.n2.vt == VT_DISPATCH );
#endif
}
HB_FUNC( OLEUNINITIALIZE )
{
if( s_bInitialized )
{
OleUninitialize();
s_bInitialized = FALSE;
}
}
HB_FUNC( GETOLEOBJECT )
{
BSTR wCLSID;
IID ClassID, iid;
LPIID riid = ( LPIID ) &IID_IDispatch;
IUnknown * pUnk = NULL;
char * cOleName = hb_parc( 1 );
void * pDisp = NULL; /* IDispatch */
/* 'void *' used intentionally to inform compiler that there is no strict-aliasing */
s_nOleError = S_OK;
wCLSID = ( BSTR ) AnsiToWide( ( LPSTR ) cOleName );
if( cOleName[ 0 ] == '{' )
s_nOleError = CLSIDFromString( wCLSID, ( LPCLSID ) &ClassID );
else
s_nOleError = CLSIDFromProgID( wCLSID, ( LPCLSID ) &ClassID );
hb_xfree( wCLSID );
if( hb_pcount() == 2 )
{
char * cID = hb_parc( 2 );
if( cID[ 0 ] == '{' )
{
wCLSID = ( BSTR ) AnsiToWide( ( LPSTR ) cID );
s_nOleError = CLSIDFromString( wCLSID, &iid );
hb_xfree( wCLSID );
}
else
memcpy( ( LPVOID ) &iid, cID, sizeof( iid ) );
riid = &iid;
}
if( s_nOleError == S_OK )
{
s_nOleError = GetActiveObject( HB_ID_REF( REFCLSID, ClassID ), NULL, &pUnk );
if( s_nOleError == S_OK )
s_nOleError = pUnk->lpVtbl->QueryInterface( pUnk, ( REFIID ) riid, &pDisp );
}
hb_retptr( pDisp );
}
HB_FUNC( MESSAGEBOX )
{
LPTSTR lpStr1 = HB_TCHAR_CONVTO( hb_parcx( 2 ) );
LPTSTR lpStr2 = HB_TCHAR_CONVTO( hb_parcx( 3 ) );
HWND hWnd = ISNUM( 1 ) ? ( HWND ) ( HB_PTRDIFF ) hb_parnint( 1 ) :
( HWND ) hb_parptr( 1 );
hb_retni( MessageBox( hWnd, lpStr1, lpStr2, hb_parni( 4 ) ) );
HB_TCHAR_FREE( lpStr1 );
HB_TCHAR_FREE( lpStr2 );
}

216
harbour/contrib/hbole/oleauto.prg
View File

@@ -4,9 +4,9 @@
/*
* Harbour Project source code:
* OLE library
* OLE Automation object
*
* Copyright 2000,2003 Jose F. Gimenez (JFG) <jfgimenez@wanadoo.es>
* Copyright 2008 Mindaugas Kavaliauskas <dbtopas at dbtopas.lt>
* www - http://www.harbour-project.org
*
* This program is free software; you can redistribute it and/or modify
@@ -50,207 +50,35 @@
*
*/
#define HB_CLS_NOTOBJECT // avoid definition of method: INIT
#include "hbclass.ch"
#include "common.ch"
#include "error.ch"
#define EG_OLEEXCEPTION 1001
CLASS TOleAuto
REQUEST __GETMESSAGE
DATA hObj
METHOD New( cAutoObj ) CONSTRUCTOR
METHOD GetActiveObject( cClass )
METHOD End()
METHOD Invoke( cMember, uParam1, uParam2, uParam3, uParam4, uParam5, uParam6 )
METHOD Set( cProperty, uParam1, uParam2, uParam3, uParam4, uParam5, uParam6 )
METHOD Get( cProperty, uParam1, uParam2, uParam3, uParam4, uParam5, uParam6 )
ERROR HANDLER OnError( cMsg, nError )
CLASS HB_OleAuto
DATA __hObj
ERROR HANDLER __OnError()
DESTRUCTOR __Dtor()
ENDCLASS
//--------------------------------------------------------------------
STATIC PROCEDURE THROW( oError )
LOCAL lError := Eval( ErrorBlock(), oError )
IF !HB_ISLOGICAL( lError ) .OR. lError
__ErrInHandler()
FUNC GetActiveObject( ... )
LOCAL oOle, hOle
hOle := OleGetActiveObject( ... )
IF ! EMPTY( hOle )
oOle := HB_OleAuto()
oOle:__hObj := hOle
ENDIF
Break( oError )
RETURN
RETURN oOle
METHOD New( uObj ) CLASS TOleAuto
LOCAL oErr
IF ISCHARACTER( uObj )
::hObj := CreateOleObject( uObj )
ELSE
::hObj := uObj
FUNC CreateObject( ... )
LOCAL oOle, hOle
hOle := OleCreateObject( ... )
IF ! EMPTY( hOle )
oOle := HB_OleAuto()
oOle:__hObj := hOle
ENDIF
IF Empty( ::hObj )
oErr := ErrorNew()
oErr:Args := hb_AParams()
oErr:CanDefault := .F.
oErr:CanRetry := .F.
oErr:CanSubstitute := .T.
oErr:Description := Ole2TxtError()
oErr:GenCode := EG_OLEEXCEPTION
oErr:Operation := ProcName()
oErr:Severity := ES_ERROR
oErr:SubCode := -1
oErr:SubSystem := "TOleAuto"
RETURN Throw( oErr )
ENDIF
RETURN Self
METHOD GetActiveObject( cClass ) CLASS TOleAuto
IF ISCHARACTER( cClass )
::hObj := GetOleObject( cClass )
// ::cClassName := cClass
ELSE
Alert( "OLE interface: Invalid parameter type to constructor TOleAuto():GetActiveObject()" )
::hObj := NIL
ENDIF
RETURN Self
//--------------------------------------------------------------------
METHOD End() CLASS TOleAuto
::hObj := NIL
RETURN NIL
//--------------------------------------------------------------------
METHOD Invoke( cMethod, uParam1, uParam2, uParam3, uParam4, uParam5, uParam6 ) CLASS TOleAuto
LOCAL uObj
IF uParam6 != NIL
uObj := OLEInvoke( ::hObj, cMethod, uParam1, uParam2, uParam3, uParam4, uParam5, uParam6 )
ELSEIF uParam5 != NIL
uObj := OLEInvoke( ::hObj, cMethod, uParam1, uParam2, uParam3, uParam4, uParam5 )
ELSEIF uParam4 != NIL
uObj := OLEInvoke( ::hObj, cMethod, uParam1, uParam2, uParam3, uParam4 )
ELSEIF uParam3 != NIL
uObj := OLEInvoke( ::hObj, cMethod, uParam1, uParam2, uParam3 )
ELSEIF uParam2 != NIL
uObj := OLEInvoke( ::hObj, cMethod, uParam1, uParam2 )
ELSEIF uParam1 != NIL
uObj := OLEInvoke( ::hObj, cMethod, uParam1 )
ELSE
uObj := OLEInvoke( ::hObj, cMethod )
ENDIF
IF OleIsObject()
RETURN TOleAuto():New( uObj )
ELSEIF Ole2TxtError() == "DISP_E_EXCEPTION"
Alert( "OLE exception: " + OleExceptionSource() + ": " + OleExceptionDescription() )
RETURN Self
ELSEIF OleError() != 0
Alert( "OLE error1: " + cMethod + ": " + Ole2TxtError() )
ENDIF
RETURN uObj
//--------------------------------------------------------------------
METHOD Set( cProperty, uParam1, uParam2, uParam3, uParam4, uParam5, uParam6 ) CLASS TOleAuto
IF uParam6 != NIL
OLESetProperty( ::hObj, cProperty, uParam1, uParam2, uParam3, uParam4, uParam5, uParam6 )
ELSEIF uParam5 != NIL
OLESetProperty( ::hObj, cProperty, uParam1, uParam2, uParam3, uParam4, uParam5 )
ELSEIF uParam4 != NIL
OLESetProperty( ::hObj, cProperty, uParam1, uParam2, uParam3, uParam4 )
ELSEIF uParam3 != NIL
OLESetProperty( ::hObj, cProperty, uParam1, uParam2, uParam3 )
ELSEIF uParam2 != NIL
OLESetProperty( ::hObj, cProperty, uParam1, uParam2 )
ELSEIF uParam1 != NIL
OLESetProperty( ::hObj, cProperty, uParam1 )
ENDIF
IF Ole2TxtError() == "DISP_E_EXCEPTION"
OLEShowException()
ELSEIF OleError() != 0
Alert( "OLE error2: " + cProperty + ": " + Ole2TxtError() )
ENDIF
RETURN nil
//--------------------------------------------------------------------
METHOD Get( cProperty, uParam1, uParam2, uParam3, uParam4, uParam5, uParam6 ) CLASS TOleAuto
LOCAL uObj
IF uParam6 != NIL
uObj := OLEGetProperty( ::hObj, cProperty, uParam1, uParam2, uParam3, uParam4, uParam5, uParam6 )
ELSEIF uParam5 != NIL
uObj := OLEGetProperty( ::hObj, cProperty, uParam1, uParam2, uParam3, uParam4, uParam5 )
ELSEIF uParam4 != NIL
uObj := OLEGetProperty( ::hObj, cProperty, uParam1, uParam2, uParam3, uParam4 )
ELSEIF uParam3 != NIL
uObj := OLEGetProperty( ::hObj, cProperty, uParam1, uParam2, uParam3 )
ELSEIF uParam2 != NIL
uObj := OLEGetProperty( ::hObj, cProperty, uParam1, uParam2 )
ELSEIF uParam1 != NIL
uObj := OLEGetProperty( ::hObj, cProperty, uParam1 )
ELSE
uObj := OLEGetProperty( ::hObj, cProperty )
ENDIF
IF Ole2TxtError() $ "DISP_E_MEMBERNOTFOUND | "+;
"DISP_E_BADPARAMCOUNT | " +;
"DISP_E_EXCEPTION"
uObj := ::Invoke( cProperty, uParam1, uParam2, uParam3, uParam4, uParam5, uParam6 )
ELSE
IF OleIsObject()
RETURN TOleAuto():New( uObj )
ELSEIF OleError() != 0
Alert( "OLE error3: " + cProperty + ": " + Ole2TxtError() )
ENDIF
ENDIF
RETURN uObj
//--------------------------------------------------------------------
METHOD OnError( uParam1, uParam2, uParam3, uParam4, uParam5, uParam6 ) CLASS TOleAuto
LOCAL cMsg := __GetMessage()
IF !( Left( cMsg, 1 ) == "_" )
RETURN ::Get( cMsg, uParam1, uParam2, uParam3, uParam4, uParam5, uParam6 )
ENDIF
RETURN ::Set( SubStr( cMsg, 2 ), uParam1, uParam2, uParam3, uParam4, uParam5, uParam6 )
EXIT PROCEDURE OLEEXIT()
OLEUninitialize()
RETURN
FUNCTION CreateObject( cString )
RETURN TOleAuto():New( cString )
FUNCTION GetActiveObject( cString )
RETURN TOleAuto():GetActiveObject( cString )
PROCEDURE OleShowException()
Alert( OleExceptionSource() + ": " + OleExceptionDescription() )
RETURN
RETURN oOle

635
harbour/contrib/hbole/olecore.c Normal file
View File

@@ -0,0 +1,635 @@
/*
* $Id$
*/
/*
* Harbour Project source code:
* OLE library
*
* Copyright 2000, 2003 Jose F. Gimenez (JFG) <jfgimenez@wanadoo.es>
* Copyright 2008 Mindaugas Kavaliauskas <dbtopas at dbtopas.lt>
* www - http://www.harbour-project.org
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2, or (at your option)
* any later version.
*
* 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. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this software; see the file COPYING. If not, write to
* the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA (or visit the web site http://www.gnu.org/).
*
* As a special exception, the Harbour Project gives permission for
* additional uses of the text contained in its release of Harbour.
*
* The exception is that, if you link the Harbour libraries with other
* files to produce an executable, this does not by itself cause the
* resulting executable to be covered by the GNU General Public License.
* Your use of that executable is in no way restricted on account of
* linking the Harbour library code into it.
*
* This exception does not however invalidate any other reasons why
* the executable file might be covered by the GNU General Public License.
*
* This exception applies only to the code released by the Harbour
* Project under the name Harbour. If you copy code from other
* Harbour Project or Free Software Foundation releases into a copy of
* Harbour, as the General Public License permits, the exception does
* not apply to the code that you add in this way. To avoid misleading
* anyone as to the status of such modified files, you must delete
* this exception notice from them.
*
* If you write modifications of your own for Harbour, it is your choice
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice.
*
*/
#include "hbapi.h"
#include "hbapiitm.h"
#include "hbapicls.h"
#include "hbapierr.h"
#include "hbvm.h"
#include "hbstack.h"
#include "hbinit.h"
#include <ole2.h>
static HRESULT s_lOleError = 0;
static PHB_DYNS s_pDyns_hb_oleauto;
static PHB_DYNS s_pDyns_hObjAccess;
static PHB_DYNS s_pDyns_hObjAssign;
static PHB_DYNS s_pDyns_GetMessage;
void hb_oleInit( void ); /* TODO: move to some hbole.h */
void HB_FUN_HB_OLEAUTO( void );
static void hb_olecore_init( void* cargo )
{
HB_SYMBOL_UNUSED( cargo );
s_pDyns_hb_oleauto = hb_dynsymGetCase( "HB_OLEAUTO" );
s_pDyns_hObjAccess = hb_dynsymGetCase( "__HOBJ" );
s_pDyns_hObjAssign = hb_dynsymGetCase( "___HOBJ" );
s_pDyns_GetMessage = hb_dynsymGetCase( "__GETMESSAGE" );
if( s_pDyns_hObjAssign == s_pDyns_GetMessage )
{
/* Never executed. Just force linkage */
HB_FUN_HB_OLEAUTO();
}
hb_oleInit();
}
/* Unicode string management */
static wchar_t* AnsiToWide( char* szString )
{
int iLen;
wchar_t* szWide;
iLen = MultiByteToWideChar( CP_ACP, MB_PRECOMPOSED, szString, -1, NULL, 0 );
szWide = ( wchar_t* ) hb_xgrab( iLen * sizeof( wchar_t ) );
MultiByteToWideChar( CP_ACP, MB_PRECOMPOSED, szString, -1, szWide, iLen );
return szWide;
}
static char* WideToAnsi( wchar_t* szWide )
{
int iLen;
char* szString;
iLen = WideCharToMultiByte( CP_ACP, 0, szWide, -1, NULL, 0, NULL, NULL );
szString = hb_xgrab( ( iLen + 1 ) * sizeof( char ) );
WideCharToMultiByte( CP_ACP, 0, szWide, -1, szString, iLen, NULL, NULL );
return szString;
}
/* Item <-> Variant conversion */
static void hb_oleItemToVariant( VARIANT* pVariant, PHB_ITEM pItem )
{
wchar_t* szString;
VariantClear( pVariant ); /* pVariant->n1.n2.vt = VT_EMPTY; */
switch( hb_itemType( pItem ) )
{
case HB_IT_STRING:
case HB_IT_MEMO:
pVariant->n1.n2.vt = VT_BSTR;
szString = AnsiToWide( hb_itemGetCPtr( pItem ) );
pVariant->n1.n2.n3.bstrVal = SysAllocString( szString );
hb_xfree( szString );
break;
case HB_IT_LOGICAL:
pVariant->n1.n2.vt = VT_BOOL;
pVariant->n1.n2.n3.boolVal = hb_itemGetL( pItem ) ? VARIANT_TRUE : VARIANT_FALSE;
break;
case HB_IT_INTEGER:
pVariant->n1.n2.vt = VT_I4;
pVariant->n1.n2.n3.lVal = hb_itemGetNL( pItem );
break;
case HB_IT_LONG:
pVariant->n1.n2.vt = VT_I8;
pVariant->n1.n2.n3.llVal = hb_itemGetNInt( pItem );
break;
case HB_IT_DOUBLE:
pVariant->n1.n2.vt = VT_R8;
pVariant->n1.n2.n3.dblVal = hb_itemGetND( pItem );
break;
case HB_IT_DATE:
pVariant->n1.n2.vt = VT_DATE;
pVariant->n1.n2.n3.dblVal = ( double ) ( hb_itemGetDL( pItem ) - 0x0024D9AB );
break;
case HB_IT_OBJECT:
if ( hb_stricmp( hb_objGetClsName( pItem ), "HB_OLEAUTO" ) == 0 )
{
hb_vmPushDynSym( s_pDyns_hObjAccess );
hb_vmPush( pItem );
hb_vmSend( 0 );
pVariant->n1.n2.vt = VT_DISPATCH;
pVariant->n1.n2.n3.pdispVal = ( IDispatch* ) hb_parptr( -1 );
}
break;
}
}
static void hb_oleVariantToItem( PHB_ITEM pItem, VARIANT* pVariant )
{
char* szString;
hb_itemClear( pItem );
switch( pVariant->n1.n2.vt )
{
case VT_BSTR:
szString = WideToAnsi( pVariant->n1.n2.n3.bstrVal );
hb_itemPutC( pItem, szString );
hb_xfree( szString );
break;
case VT_BOOL:
hb_itemPutL( pItem, pVariant->n1.n2.n3.boolVal );
break;
case VT_DISPATCH:
{
PHB_ITEM pRet;
if ( pVariant->n1.n2.n3.pdispVal )
{
/* TODO: save/restore stack return item */
hb_vmPushDynSym( s_pDyns_hb_oleauto );
hb_vmPushNil();
hb_vmDo( 0 );
pRet = hb_itemNew( NULL );
hb_itemMove( pRet, hb_stackReturnItem() );
hb_vmPushDynSym( s_pDyns_hObjAssign );
hb_vmPush( pRet );
hb_vmPushPointer( pVariant->n1.n2.n3.pdispVal );
hb_vmSend( 1 );
hb_itemMove( pItem, pRet );
hb_itemRelease( pRet );
}
break;
}
case VT_I1:
hb_itemPutNI( pItem, ( int ) pVariant->n1.n2.n3.cVal );
break;
case VT_I2:
hb_itemPutNI( pItem, ( int ) pVariant->n1.n2.n3.iVal );
break;
case VT_I4:
hb_itemPutNL( pItem, pVariant->n1.n2.n3.lVal );
break;
case VT_I8:
hb_itemPutNInt( pItem, pVariant->n1.n2.n3.llVal );
break;
case VT_UI1:
hb_itemPutNI( pItem, ( int ) pVariant->n1.n2.n3.bVal );
break;
case VT_UI2:
hb_itemPutNI( pItem, ( int ) pVariant->n1.n2.n3.uiVal );
break;
case VT_UI4:
hb_itemPutNInt( pItem, ( HB_LONG ) pVariant->n1.n2.n3.ulVal );
break;
case VT_UI8:
/* TODO: sign is lost. Convertion to double will lose significant digits. */
hb_itemPutNInt( pItem, ( HB_LONG ) pVariant->n1.n2.n3.ullVal );
break;
case VT_R8:
hb_itemPutND( pItem, pVariant->n1.n2.n3.dblVal );
break;
case VT_INT:
hb_itemPutNI( pItem, pVariant->n1.n2.n3.intVal );
break;
case VT_UINT:
hb_itemPutNInt( pItem, ( HB_LONG ) pVariant->n1.n2.n3.uintVal );
break;
case VT_DATE:
hb_itemPutDL( pItem, ( long ) pVariant->n1.n2.n3.dblVal + 0x0024D9AB );
break;
}
}
/* IDispatch parameters, return value handling */
static void GetParams( DISPPARAMS* dParams )
{
VARIANTARG* pArgs = NULL;
UINT uiArgCount, uiArg;
uiArgCount = ( UINT ) hb_pcount();
if( uiArgCount > 0 )
{
pArgs = ( VARIANTARG* ) hb_xgrab( sizeof( VARIANTARG ) * uiArgCount );
for( uiArg = 0; uiArg < uiArgCount; uiArg++ )
{
VariantInit( &( pArgs[ uiArg ] ) );
hb_oleItemToVariant( & pArgs[ uiArg ], hb_param( uiArgCount - uiArg, HB_IT_ANY ) );
}
}
dParams->rgvarg = pArgs;
dParams->cArgs = uiArgCount;
dParams->rgdispidNamedArgs = 0;
dParams->cNamedArgs = 0;
}
static void FreeParams( DISPPARAMS * dispparam )
{
UINT ui;
if( dispparam->cArgs > 0 )
{
for( ui = 0; ui < dispparam->cArgs; ui++ )
VariantClear( & ( dispparam->rgvarg[ ui ] ) );
hb_xfree( dispparam->rgvarg );
}
}
/* PRG level functions and methods */
HB_FUNC( OLECREATEOBJECT ) /* ( cOleName | cCLSID [, cIID ] ) */
{
wchar_t* cCLSID;
GUID ClassID, iid;
REFIID riid = &IID_IDispatch;
IDispatch* pDisp = NULL;
cCLSID = AnsiToWide( hb_parc( 1 ) );
if ( hb_parc( 1 )[ 0 ] == '{' )
s_lOleError = CLSIDFromString( (LPOLESTR) cCLSID, &ClassID );
else
s_lOleError = CLSIDFromProgID( (LPCOLESTR) cCLSID, &ClassID );
hb_xfree( cCLSID );
if ( hb_pcount() == 2 )
{
if ( hb_parc( 2 )[ 0 ] == '{' )
{
cCLSID = AnsiToWide( hb_parc( 2 ) );
s_lOleError = CLSIDFromString( (LPOLESTR) cCLSID, &iid );
hb_xfree( cCLSID );
}
else
memcpy( (LPVOID) &iid, hb_parc( 2 ), sizeof( iid ) );
(LPVOID) riid = &iid;
}
if ( s_lOleError == S_OK )
s_lOleError = CoCreateInstance( &ClassID, NULL, CLSCTX_SERVER, riid, (LPVOID) &pDisp );
hb_retptr( pDisp );
}
HB_FUNC( OLEGETACTIVEOBJECT ) /* ( cOleName | cCLSID [, cIID ] ) */
{
BSTR wCLSID;
IID ClassID, iid;
LPIID riid = (LPIID) &IID_IDispatch;
IDispatch* pDisp = NULL;
IUnknown* pUnk = NULL;
char* cOleName = hb_parc( 1 );
s_lOleError = S_OK;
wCLSID = (BSTR) AnsiToWide( (LPSTR) cOleName );
if ( cOleName[ 0 ] == '{' )
s_lOleError = CLSIDFromString( wCLSID, (LPCLSID) &ClassID );
else
s_lOleError = CLSIDFromProgID( wCLSID, (LPCLSID) &ClassID );
hb_xfree( wCLSID );
if ( hb_pcount() == 2 )
{
char * cID = hb_parc( 2 );
if ( cID[ 0 ] == '{' )
{
wCLSID = (BSTR) AnsiToWide( (LPSTR) cID );
s_lOleError = CLSIDFromString( wCLSID, &iid );
hb_xfree( wCLSID );
}
else
{
memcpy( ( LPVOID ) &iid, cID, sizeof( iid ) );
}
riid = &iid;
}
if ( s_lOleError == S_OK )
{
s_lOleError = GetActiveObject( &ClassID, NULL, &pUnk );
if ( s_lOleError == S_OK )
s_lOleError = pUnk->lpVtbl->QueryInterface( pUnk, riid, (void **) &pDisp );
}
hb_retptr( pDisp );
}
HB_FUNC( OLERELEASE )
{
IDispatch * pDisp = ( IDispatch* ) hb_parptr( 1 );
s_lOleError = pDisp->lpVtbl->Release( pDisp );
hb_retl( s_lOleError == S_OK );
}
HB_FUNC( OLEERROR )
{
hb_retnl( s_lOleError );
}
HB_FUNC( OLEERRORTEXT )
{
switch ( s_lOleError )
{
case S_OK:
hb_retc( "" );
break;
case CO_E_CLASSSTRING:
hb_retc( "CO_E_CLASSSTRING" );
break;
case OLE_E_WRONGCOMPOBJ:
hb_retc( "OLE_E_WRONGCOMPOBJ" );
break;
case REGDB_E_CLASSNOTREG:
hb_retc( "REGDB_E_CLASSNOTREG" );
break;
case REGDB_E_WRITEREGDB:
hb_retc( "REGDB_E_WRITEREGDB" );
break;
case E_OUTOFMEMORY:
hb_retc( "E_OUTOFMEMORY" );
break;
case E_INVALIDARG:
hb_retc( "E_INVALIDARG" );
break;
case E_UNEXPECTED:
hb_retc( "E_UNEXPECTED" );
break;
case DISP_E_UNKNOWNNAME:
hb_retc( "DISP_E_UNKNOWNNAME" );
break;
case DISP_E_UNKNOWNLCID:
hb_retc( "DISP_E_UNKNOWNLCID" );
break;
case DISP_E_BADPARAMCOUNT:
hb_retc( "DISP_E_BADPARAMCOUNT" );
break;
case DISP_E_BADVARTYPE:
hb_retc( "DISP_E_BADVARTYPE" );
break;
case DISP_E_EXCEPTION:
hb_retc( "DISP_E_EXCEPTION" );
break;
case DISP_E_MEMBERNOTFOUND:
hb_retc( "DISP_E_MEMBERNOTFOUND" );
break;
case DISP_E_NONAMEDARGS:
hb_retc( "DISP_E_NONAMEDARGS" );
break;
case DISP_E_OVERFLOW:
hb_retc( "DISP_E_OVERFLOW" );
break;
case DISP_E_PARAMNOTFOUND:
hb_retc( "DISP_E_PARAMNOTFOUND" );
break;
case DISP_E_TYPEMISMATCH:
hb_retc( "DISP_E_TYPEMISMATCH" );
break;
case DISP_E_UNKNOWNINTERFACE:
hb_retc( "DISP_E_UNKNOWNINTERFACE" );
break;
case DISP_E_PARAMNOTOPTIONAL:
hb_retc( "DISP_E_PARAMNOTOPTIONAL" );
break;
default:
hb_retc( "Unknown OLE error" );
break;
}
}
HB_FUNC( HB_OLEAUTO___ONERROR )
{
IDispatch* pDisp;
char* szMethod;
wchar_t* szMethodWide;
OLECHAR* pMemberArray;
DISPID dispid;
DISPPARAMS dispparam;
VARIANTARG RetVal;
EXCEPINFO excep;
UINT uiArgErr;
/* Get object handle */
hb_vmPushDynSym( s_pDyns_hObjAccess );
hb_vmPush( hb_stackSelfItem() );
hb_vmSend( 0 );
pDisp = ( IDispatch* ) hb_parptr( -1 );
/* TODO: implement hb_clsGetMessageName() */
hb_vmPushDynSym( s_pDyns_GetMessage );
hb_vmPushNil();
hb_vmDo( 0 );
if ( ! pDisp )
{
hb_errRT_BASE_SubstR( EG_ARG, 1005, "Invalid HB_OLEAUTO object", hb_parc( -1 ), HB_ERR_ARGS_SELFPARAMS );
}
/* Take a copy of szMethod string, because return item could be overwritten */
szMethod = hb_strdup( hb_parc( -1 ) );
szMethodWide = AnsiToWide( szMethod );
/* Try property put */
if( szMethod[ 0 ] == '_' && hb_pcount() > 0 )
{
pMemberArray = &szMethodWide[ 1 ];
s_lOleError = pDisp->lpVtbl->GetIDsOfNames( pDisp, &IID_NULL, &pMemberArray,
1, LOCALE_USER_DEFAULT, &dispid );
if ( s_lOleError == S_OK )
{
DISPID lPropPut = DISPID_PROPERTYPUT;
memset( &excep, 0, sizeof( excep ) );
GetParams( &dispparam );
dispparam.rgdispidNamedArgs = &lPropPut;
dispparam.cNamedArgs = 1;
s_lOleError = pDisp->lpVtbl->Invoke( pDisp, dispid, &IID_NULL,
LOCALE_USER_DEFAULT,
DISPATCH_PROPERTYPUT, &dispparam,
NULL, &excep, &uiArgErr );
FreeParams( &dispparam );
hb_xfree( szMethodWide );
hb_xfree( szMethod );
hb_ret();
return;
}
}
/* Try property get and invoke */
pMemberArray = szMethodWide;
s_lOleError = pDisp->lpVtbl->GetIDsOfNames( pDisp, &IID_NULL, &pMemberArray,
1, LOCALE_USER_DEFAULT, &dispid );
hb_xfree( szMethodWide );
if ( s_lOleError == S_OK )
{
memset( &excep, 0, sizeof( excep ) );
VariantInit( &RetVal );
GetParams( &dispparam );
s_lOleError = pDisp->lpVtbl->Invoke( pDisp, dispid, &IID_NULL,
LOCALE_USER_DEFAULT,
DISPATCH_PROPERTYGET | DISPATCH_METHOD,
&dispparam, &RetVal, &excep, &uiArgErr );
FreeParams( &dispparam );
hb_oleVariantToItem( hb_stackReturnItem(), & RetVal );
if( RetVal.n1.n2.vt != VT_DISPATCH )
VariantClear( &RetVal );
hb_xfree( szMethod );
return;
}
/* TODO: add description containing TypeName of the object */
if( szMethod[ 0 ] == '_' )
hb_errRT_BASE_SubstR( EG_NOVARMETHOD, 1005, NULL, szMethod + 1, HB_ERR_ARGS_BASEPARAMS );
else
hb_errRT_BASE_SubstR( EG_NOMETHOD, 1004, NULL, szMethod, HB_ERR_ARGS_BASEPARAMS );
hb_xfree( szMethod );
}
HB_FUNC( HB_OLEAUTO___DTOR )
{
IDispatch* pDisp;
/* Get object handle */
hb_vmPushDynSym( s_pDyns_hObjAccess );
hb_vmPush( hb_stackSelfItem() );
hb_vmSend( 0 );
pDisp = ( IDispatch* ) hb_parptr( -1 );
if( pDisp )
pDisp->lpVtbl->Release( pDisp );
}
HB_CALL_ON_STARTUP_BEGIN( _hb_olecore_init_ )
hb_vmAtInit( hb_olecore_init, NULL );
HB_CALL_ON_STARTUP_END( _hb_olecore_init_ )
#if defined( HB_PRAGMA_STARTUP )
#pragma startup _hb_olecore_init_
#elif defined( HB_MSC_STARTUP )
#if defined( HB_OS_WIN_64 )
#pragma section( HB_MSC_START_SEGMENT, long, read )
#endif
#pragma data_seg( HB_MSC_START_SEGMENT )
static HB_$INITSYM hb_vm_auto_olecore_init = _hb_olecore_init_;
#pragma data_seg()
#endif

86
harbour/contrib/hbole/oleinit.c Normal file
View File

@@ -0,0 +1,86 @@
/*
* $Id$
*/
/*
* Harbour Project source code:
* OLE initialization
*
* Copyright 2008 Mindaugas Kavaliauskas <dbtopas at dbtopas.lt>
* www - http://www.harbour-project.org
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2, or (at your option)
* any later version.
*
* 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. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this software; see the file COPYING. If not, write to
* the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA (or visit the web site http://www.gnu.org/).
*
* As a special exception, the Harbour Project gives permission for
* additional uses of the text contained in its release of Harbour.
*
* The exception is that, if you link the Harbour libraries with other
* files to produce an executable, this does not by itself cause the
* resulting executable to be covered by the GNU General Public License.
* Your use of that executable is in no way restricted on account of
* linking the Harbour library code into it.
*
* This exception does not however invalidate any other reasons why
* the executable file might be covered by the GNU General Public License.
*
* This exception applies only to the code released by the Harbour
* Project under the name Harbour. If you copy code from other
* Harbour Project or Free Software Foundation releases into a copy of
* Harbour, as the General Public License permits, the exception does
* not apply to the code that you add in this way. To avoid misleading
* anyone as to the status of such modified files, you must delete
* this exception notice from them.
*
* If you write modifications of your own for Harbour, it is your choice
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice.
*
*/
#include "hbvm.h"
#include "windows.h"
/*
* Duplicated OleUninitialize() call causes GPF. So, if a few OLE libraries
* is used inside Harbour code, you can expect GPF on application exit.
* This code does not implement any OLE interface except initialization. It is
* have to be used from all other OLE libraries. [Mindaugas]
*/
static int s_iOleInit = 0;
static void hb_ole_exit( void* cargo )
{
HB_SYMBOL_UNUSED( cargo );
if( s_iOleInit )
{
OleUninitialize();
s_iOleInit = 0;
}
}
HB_EXPORT void hb_oleInit()
{
if( ! s_iOleInit )
{
OleInitialize( NULL );
hb_vmAtExit( hb_ole_exit, NULL );
}
s_iOleInit++;
}