diff --git a/harbour/ChangeLog b/harbour/ChangeLog index 4f0e9bd410..2a46c7146d 100644 --- a/harbour/ChangeLog +++ b/harbour/ChangeLog @@ -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 diff --git a/harbour/contrib/hbole/Makefile b/harbour/contrib/hbole/Makefile index 8974e84f9c..1d0e63c3ae 100644 --- a/harbour/contrib/hbole/Makefile +++ b/harbour/contrib/hbole/Makefile @@ -9,7 +9,8 @@ LIBNAME=hbole ifeq ($(HB_ARCHITECTURE),win) C_SOURCES=\ - ole2.c \ + oleinit.c \ + olecore.c \ PRG_SOURCES=\ oleauto.prg \ diff --git a/harbour/contrib/hbole/ole2.c b/harbour/contrib/hbole/ole2.c deleted file mode 100644 index c38c7ff641..0000000000 --- a/harbour/contrib/hbole/ole2.c +++ /dev/null @@ -1,665 +0,0 @@ -/* - * $Id$ - */ - -/* - * Harbour Project source code: - * OLE library - * - * Copyright 2000,2003 Jose F. Gimenez (JFG) - * 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 - -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 ); -} diff --git a/harbour/contrib/hbole/oleauto.prg b/harbour/contrib/hbole/oleauto.prg index 8699d72d33..5fce3b789a 100644 --- a/harbour/contrib/hbole/oleauto.prg +++ b/harbour/contrib/hbole/oleauto.prg @@ -4,9 +4,9 @@ /* * Harbour Project source code: - * OLE library + * OLE Automation object * - * Copyright 2000,2003 Jose F. Gimenez (JFG) + * Copyright 2008 Mindaugas Kavaliauskas * 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 diff --git a/harbour/contrib/hbole/olecore.c b/harbour/contrib/hbole/olecore.c new file mode 100644 index 0000000000..a9220cb92c --- /dev/null +++ b/harbour/contrib/hbole/olecore.c @@ -0,0 +1,635 @@ +/* + * $Id$ + */ + +/* + * Harbour Project source code: + * OLE library + * + * Copyright 2000, 2003 Jose F. Gimenez (JFG) + * Copyright 2008 Mindaugas Kavaliauskas + * 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 + +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 diff --git a/harbour/contrib/hbole/oleinit.c b/harbour/contrib/hbole/oleinit.c new file mode 100644 index 0000000000..10deec87d9 --- /dev/null +++ b/harbour/contrib/hbole/oleinit.c @@ -0,0 +1,86 @@ +/* + * $Id$ + */ + +/* + * Harbour Project source code: + * OLE initialization + * + * Copyright 2008 Mindaugas Kavaliauskas + * 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++; +}