From 4b6f2250dfcc78fed9968777d0fe693149728bed Mon Sep 17 00:00:00 2001 From: "Alexander S.Kresin" Date: Tue, 15 Apr 2003 09:12:31 +0000 Subject: [PATCH] 2003-04-15 13:10 UTC+0300 Alexander Kresin --- harbour/ChangeLog | 11 + harbour/contrib/ole/bldtest.bat | 9 + harbour/contrib/ole/build32.bat | 24 ++ harbour/contrib/ole/hbtest.prg | 171 +++++++++ harbour/contrib/ole/ole2.c | 615 ++++++++++++++++++++++++++++++++ harbour/contrib/ole/oleauto.prg | 221 ++++++++++++ 6 files changed, 1051 insertions(+) create mode 100644 harbour/contrib/ole/bldtest.bat create mode 100644 harbour/contrib/ole/build32.bat create mode 100644 harbour/contrib/ole/hbtest.prg create mode 100644 harbour/contrib/ole/ole2.c create mode 100644 harbour/contrib/ole/oleauto.prg diff --git a/harbour/ChangeLog b/harbour/ChangeLog index 52c16926c2..e2263591b4 100644 --- a/harbour/ChangeLog +++ b/harbour/ChangeLog @@ -8,6 +8,17 @@ 2002-12-01 23:12 UTC+0100 Foo Bar */ +2003-04-15 13:10 UTC+0300 Alexander Kresin + + contrib/ole + + contrib/ole/bldtest.bat + + contrib/ole/build32.bat + + contrib/ole/hbtest.prg + + contrib/ole/ole2.c + + contrib/ole/oleauto.prg + + With a kind permission of the author, José F. Giménez , + ole library for harbour added. + Some unused stuff is removed from the original files, few bug fixes are made. + 2003-04-14 14:45 UTC-0400 David G. Holm * source/common/hbgete.c ! Added #ifdef to allow OS/2 GCC to use PSZ and OS/2 VAC++ to use PCSZ for EnvValue. diff --git a/harbour/contrib/ole/bldtest.bat b/harbour/contrib/ole/bldtest.bat new file mode 100644 index 0000000000..a990cf43b8 --- /dev/null +++ b/harbour/contrib/ole/bldtest.bat @@ -0,0 +1,9 @@ +@set HB_BIN_INSTALL=..\..\bin +@set HB_LIB_INSTALL=..\..\lib\ +@set HB_INC_INSTALL=..\..\include\ + + %HB_BIN_INSTALL%\harbour %1.prg -n -i%HB_INC_INSTALL% %2 + bcc32 -O2 -d -I%HB_INC_INSTALL% -L%HB_LIB_INSTALL% %1.c debug.lib vm.lib rtl.lib gtwin.lib lang.lib rdd.lib macro.lib pp.lib dbfntx.lib dbfcdx.lib common.lib codepage.lib hbole.lib + del %1.c + del %1.obj + del %1.tds diff --git a/harbour/contrib/ole/build32.bat b/harbour/contrib/ole/build32.bat new file mode 100644 index 0000000000..def5af2c87 --- /dev/null +++ b/harbour/contrib/ole/build32.bat @@ -0,0 +1,24 @@ +@echo off + +SET HB_INCLUDE=..\..\include + +bcc32 -c -I.;%HB_INCLUDE% ole2.c +if errorlevel 1 goto end + +harbour oleauto /n /i%HB_INCLUDE% +if errorlevel 1 goto end + +bcc32 -M -c -O2 -I%HB_INCLUDE% -tW oleauto.c +if errorlevel 1 goto end + +if exist hbole.lib del hbole.lib +tlib hbole +ole2 +oleauto +if errorlevel 1 goto end + +copy hbole.lib ..\..\lib\*.* > nul + +:END +del oleauto.c +del ole2.obj +del oleauto.obj +del hbole.lib diff --git a/harbour/contrib/ole/hbtest.prg b/harbour/contrib/ole/hbtest.prg new file mode 100644 index 0000000000..1203de1908 --- /dev/null +++ b/harbour/contrib/ole/hbtest.prg @@ -0,0 +1,171 @@ +* +* HBTEST.PRG +* +* Este ejemplo es para probar con Harbour en modo consola, sin FiveWin +* para Harbour. +* +* This example is done for testing with Harbour in console mode, without +* FiveWin for Harbour. +* + + +#define CRLF Chr( 13 ) + Chr( 10 ) + + +PROCEDURE MAIN() + + LOCAL nOption + + CLS + SetColor("W+/R") + @ 6, 25 TO 16, 55 DOUBLE + @ 8, 28 SAY "Probar OLE con..." + + While .t. + @ 10, 32 PROMPT "Excel" + @ 11, 32 PROMPT "Word" + @ 12, 32 PROMPT "Internet Explorer" + @ 13, 32 PROMPT "Outlook" + @ 14, 32 PROMPT "Salir" + + MENU TO nOption + + IF nOption == 0 + nOption := 5 + ELSEIF nOption == 1 + EXCEL97() + ELSEIF nOption == 2 + WORD97() + ELSEIF nOption == 3 + IEXPLORER() + ELSEIF nOption == 4 + OUTLOOK() + ELSEIF nOption == 5 + EXIT + ENDIF + End + + SetColor("W/N") + CLS + +RETURN + +//-------------------------------------------------------------------- + +STATIC PROCEDURE EXCEL97() + + LOCAL oExcel, oHoja + + oExcel := TOleAuto():New( "Excel.Application" ) + + oExcel:WorkBooks:Add() + + oHoja := oExcel:ActiveSheet() + + oHoja:Cells:Font:Name := "Arial" + oHoja:Cells:Font:Size := 12 + + oHoja:Cells( 3, 1 ):Value := "Texto:" + oHoja:Cells( 3, 2 ):Value := "Esto es un texto" + oHoja:Cells( 4, 1 ):Value := "Número:" + oHoja:Cells( 4, 2 ):NumberFormat := "#.##0,00" + oHoja:Cells( 4, 2 ):Value := 1234.50 + oHoja:Cells( 5, 1 ):Value := "Lógico:" + oHoja:Cells( 5, 2 ):Value := .T. + oHoja:Cells( 6, 1 ):Value := "Fecha:" + oHoja:Cells( 6, 2 ):Value := DATE() + + oHoja:Columns( 1 ):Font:Bold := .T. + oHoja:Columns( 2 ):HorizontalAlignment := -4152 // xlRight + + oHoja:Columns( 1 ):AutoFit() + oHoja:Columns( 2 ):AutoFit() + + oHoja:Cells( 1, 1 ):Value := "OLE desde FW" + oHoja:Cells( 1, 1 ):Font:Size := 16 + oHoja:Range( "A1:B1" ):HorizontalAlignment := 7 + + oHoja:Cells( 1, 1 ):Select() + oExcel:Visible := .T. + + oHoja:End() + oExcel:End() + +RETURN + +//-------------------------------------------------------------------- + +STATIC PROCEDURE WORD97() + + LOCAL oWord, oTexto + + oWord:=TOleAuto():New( "Word.Application" ) + + oWord:Documents:Add() + + oTexto := oWord:Selection() + + oTexto:Text := "OLE desde FW"+CRLF + oTexto:Font:Name := "Arial" + oTexto:Font:Size := 48 + oTexto:Font:Bold := .T. + + oWord:Visible := .T. + oWord:WindowState := 1 // Maximizado + + oTexto:End() + oWord:End() + +RETURN + +//-------------------------------------------------------------------- + +STATIC PROCEDURE IEXPLORER() + + LOCAL oIE + + oIE:=TOleAuto():New( "InternetExplorer.Application" ) + + oIE:Visible := .T. + + oIE:Navigate( "http://www.fivetech.com" ) + + oIE:End() + +RETURN + +//-------------------------------------------------------------------- + +STATIC PROCEDURE OUTLOOK() + + LOCAL oOL, oLista, oMail, i + + oOL := TOleAuto():New( "Outlook.Application.9" ) + + IF Ole2TxtError() != "S_OK" + + Alert("Outlook 2000 no está disponible.", "Error") + + ELSE + + oMail := oOL:CreateItem( 0 ) // olMailItem + + FOR i := 1 TO 10 + oMail:Recipients:Add( "Contacto" + LTRIM( STR( i, 2 ) ) + ; + "" ) + NEXT + + oLista := oOL:CreateItem( 7 ) // olDistributionListItem + oLista:DLName := "Prueba de lista de distribución" + oLista:Display( .F. ) + oLista:AddMembers( oMail:Recipients ) + oLista:Save() + oLista:Close( 0 ) + + oMail:End() + oLista:End() + oOL:End() + + ENDIF + +RETURN diff --git a/harbour/contrib/ole/ole2.c b/harbour/contrib/ole/ole2.c new file mode 100644 index 0000000000..1c10cc06df --- /dev/null +++ b/harbour/contrib/ole/ole2.c @@ -0,0 +1,615 @@ +/* + * $Id$ + */ + +/* + * Harbour Project source code: + * OLE library + * + * Copyright 2000,2003 José F. Giménez (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 * +* * +\************************************************************************/ + +#include +#include + +#include +#include + +static far VARIANTARG RetVal; +static EXCEPINFO excep; +static HRESULT nOleError = 0; +static int lInitialized = 0; + +static double DateToDbl( LPSTR cDate ) +{ + double nDate; + + nDate = hb_dateEncStr( cDate ) - 0x0024d9abL; + + return ( nDate ); +} + +static LPSTR DblToDate( double nDate ) +{ + static char *cDate = "00000000"; + + hb_dateDecStr( cDate, nDate + 0x0024d9abL ); + + return ( cDate ); +} + +static LPSTR AnsiToWide( LPSTR cAnsi ) +{ + unsigned short wLen; + LPSTR cString; + + wLen = MultiByteToWideChar( CP_ACP, MB_PRECOMPOSED, cAnsi, -1, 0, 0 ); + cString = ( char * ) hb_xgrab( wLen * 2 ); + MultiByteToWideChar( CP_ACP, MB_PRECOMPOSED, cAnsi, -1, + ( LPWSTR ) cString, wLen ); + return ( cString ); +} + +static LPSTR WideToAnsi( LPSTR cWide ) +{ + unsigned short wLen; + LPSTR cString; + + wLen = WideCharToMultiByte( CP_ACP, 0, ( LPWSTR ) cWide, -1, + cString, 0, NULL, NULL ); + cString = hb_xgrab( (!wLen)? 2:wLen ); + WideCharToMultiByte( CP_ACP, 0, ( LPWSTR ) cWide, -1, + cString, wLen, NULL, NULL ); + + return ( cString ); +} + +static void GetParams(DISPPARAMS * dParams) +{ + VARIANTARG * pArgs = NULL; + PHB_ITEM uParam, Self; + int n, nArgs, nArg; + double date; + LPSTR cString; + + nArgs = hb_pcount() - 2; + + if( nArgs > 0 ) + { + pArgs = ( VARIANTARG * ) hb_xgrab( sizeof( VARIANTARG ) * nArgs ); + + for( n = 0; n < nArgs; n++ ) + { + // Los parametros en VARIANTARG[] hay que ponerlos en orden inverso + nArg = nArgs + 2 - n; + + VariantInit( &( pArgs[ n ] ) ); + + uParam = hb_param( nArg, 0xFFFF ); + + switch( uParam->type ) + { + case '\0': + pArgs[ n ].n1.n2.vt = VT_EMPTY; + break; + + case HB_IT_STRING: + case HB_IT_MEMO: + pArgs[ n ].n1.n2.vt = VT_BSTR; + cString = AnsiToWide( hb_parc( nArg ) ); + pArgs[ n ].n1.n2.n3.bstrVal = SysAllocString( (LPVOID) cString ); + hb_xfree( cString ); + break; + + case HB_IT_LOGICAL: + pArgs[ n ].n1.n2.vt = VT_BOOL; + pArgs[ n ].n1.n2.n3.boolVal = hb_parl( nArg ); + break; + + case HB_IT_INTEGER: + case HB_IT_LONG: + case HB_IT_NUMERIC: + pArgs[ n ].n1.n2.vt = VT_I4; + pArgs[ n ].n1.n2.n3.lVal = hb_parnl( nArg ); + break; + + case HB_IT_DOUBLE: + pArgs[ n ].n1.n2.vt = VT_R8; + pArgs[ n ].n1.n2.n3.dblVal = hb_parnd( nArg ); + break; + case HB_IT_DATE: + pArgs[ n ].n1.n2.vt = VT_DATE; + pArgs[ n ].n1.n2.n3.dblVal = DateToDbl( hb_pards( nArg ) ); + break; + + case HB_IT_OBJECT: + { + PHB_DYNS pData; + pArgs[ n ].n1.n2.vt = VT_EMPTY; + if ( hb_stricmp( hb_objGetClsName( uParam ), "TOleAuto" ) == 0 ) + { + pData = hb_dynsymFindName( "hObj" ); + if( pData ) + { + hb_vmPushSymbol( pData->pSymbol ); + hb_vmPush( uParam ); + hb_vmDo( 0 ); + pArgs[ n ].n1.n2.vt = VT_DISPATCH; + pArgs[ n ].n1.n2.n3.pdispVal = ( IDispatch * ) hb_parnl( -1 ); + } + } + } + break; + } + } + } + + dParams->rgvarg = pArgs; + dParams->cArgs = nArgs; + dParams->rgdispidNamedArgs = 0; + dParams->cNamedArgs = 0; + +} + +static void FreeParams(DISPPARAMS * dParams) +{ + int n; + + if( dParams->cArgs > 0 ) + { + for( n = 0; n < ( int ) dParams->cArgs; n++ ) + VariantClear( &(dParams->rgvarg[ n ]) ); + + hb_xfree( ( LPVOID ) dParams->rgvarg ); + } +} + +static void RetValue( void ) +{ + LPSTR cString; + + switch( RetVal.n1.n2.vt ) + { + case VT_BSTR: + cString = WideToAnsi( ( LPSTR ) RetVal.n1.n2.n3.bstrVal ); + hb_retc( cString ); + hb_xfree( cString ); + break; + + case VT_BOOL: + hb_retl( RetVal.n1.n2.n3.boolVal ); + break; + + case VT_DISPATCH: + hb_retnl( ( LONG ) RetVal.n1.n2.n3.pdispVal ); + break; + + case VT_I4: + hb_retnl( ( LONG ) RetVal.n1.n2.n3.iVal ); + break; + + case VT_R8: + hb_retnd( RetVal.n1.n2.n3.dblVal ); + break; + + case VT_DATE: + hb_retds( DblToDate( RetVal.n1.n2.n3.dblVal ) ); + break; + + case VT_EMPTY: + hb_ret(); + break; + + default: + if ( nOleError == S_OK ) + (LONG) nOleError = -1; + hb_ret(); + break; + } + + if( RetVal.n1.n2.vt != VT_DISPATCH ) + VariantClear( &RetVal ); + +} + + +HB_FUNC( CREATEOLEOBJECT ) // ( cOleName | cCLSID [, cIID ] ) +{ + LPSTR cCLSID; + GUID ClassID, iid; + REFIID riid = &IID_IDispatch; + IDispatch * pDisp = NULL; + + nOleError = S_OK; + + if ( !lInitialized ) + nOleError = OleInitialize( NULL ); + lInitialized = 1; + + if ( (nOleError == S_OK) || (nOleError == (HRESULT) S_FALSE) ) + { + + cCLSID = AnsiToWide( hb_parc( 1 ) ); + if ( hb_parc( 1 )[ 0 ] == '{' ) + nOleError = CLSIDFromString( ( LPOLESTR ) cCLSID, &ClassID ); + else + nOleError = CLSIDFromProgID( ( LPCOLESTR ) cCLSID, &ClassID ); + hb_xfree( cCLSID ); + + if ( hb_pcount() == 2 ) + { + if ( hb_parc( 2 )[ 0 ] == '{' ) + { + cCLSID = AnsiToWide( hb_parc( 2 ) ); + nOleError = CLSIDFromString( ( LPOLESTR ) cCLSID, &iid ); + hb_xfree( cCLSID ); + } + else + memcpy( ( LPVOID ) &iid, hb_parc( 2 ), sizeof( iid ) ); + + ( LPVOID ) riid = &iid; + } + + if ( nOleError == S_OK ) + nOleError = CoCreateInstance( &ClassID, NULL, CLSCTX_SERVER, + riid, (LPVOID) &pDisp ); + } + + hb_retnl( ( LONG ) pDisp ); + +} + +HB_FUNC( OLESHOWEXCEPTION ) +{ + if ( (LONG) nOleError == DISP_E_EXCEPTION ) + { + LPSTR source, description; + + source = WideToAnsi( (LPVOID) excep.bstrSource ); + description = WideToAnsi( (LPVOID) excep.bstrDescription ); + MessageBox( NULL, description, source, MB_ICONHAND ); + hb_xfree( source ); + hb_xfree( description ); + } +} + +HB_FUNC( OLEINVOKE ) // (hOleObject, szMethodName, uParams...) +{ + IDispatch * pDisp = ( IDispatch * ) hb_parnl( 1 ); + LPSTR cMember; + DISPID lDispID; + DISPPARAMS dParams; + UINT uArgErr; + + VariantInit( &RetVal ); + memset( (LPBYTE) &excep, 0, sizeof( excep ) ); + + cMember = AnsiToWide( hb_parc( 2 ) ); + nOleError = pDisp->lpVtbl->GetIDsOfNames( pDisp, &IID_NULL, + ( LPVOID ) &cMember, 1, + LOCALE_USER_DEFAULT, &lDispID ); + hb_xfree( cMember ); + + if ( nOleError == S_OK ) + { + GetParams( &dParams ); + nOleError = pDisp->lpVtbl->Invoke( pDisp, + lDispID, + &IID_NULL, + LOCALE_USER_DEFAULT, + DISPATCH_METHOD, + &dParams, + &RetVal, + &excep, + &uArgErr ) ; + FreeParams( &dParams ); + } + + RetValue(); +} + +HB_FUNC( OLESETPROPERTY ) // (hOleObject, cPropName, uValue, uParams...) +{ + IDispatch * pDisp = ( IDispatch * ) hb_parnl( 1 ); + LPSTR cMember; + DISPID lDispID, lPropPut = DISPID_PROPERTYPUT; + DISPPARAMS dParams; + UINT uArgErr; + + VariantInit( &RetVal ); + memset( (LPBYTE) &excep, 0, sizeof( excep ) ); + + cMember = AnsiToWide( hb_parc( 2 ) ); + nOleError = pDisp->lpVtbl->GetIDsOfNames( pDisp, &IID_NULL, + ( LPVOID ) &cMember, 1, + LOCALE_USER_DEFAULT, &lDispID ); + hb_xfree( cMember ); + + if ( nOleError == S_OK ) + { + GetParams( &dParams ); + dParams.rgdispidNamedArgs = &lPropPut; + dParams.cNamedArgs = 1; + + nOleError = pDisp->lpVtbl->Invoke( pDisp, + lDispID, + &IID_NULL, + LOCALE_USER_DEFAULT, + DISPATCH_PROPERTYPUT, + &dParams, + NULL, // No return value + &excep, + &uArgErr ); + + FreeParams( &dParams ); + } + + hb_ret(); +} + +HB_FUNC( OLEGETPROPERTY ) // (hOleObject, cPropName, uParams...) +{ + IDispatch * pDisp = ( IDispatch * ) hb_parnl( 1 ); + LPSTR cMember; + DISPID lDispID; + DISPPARAMS dParams; + UINT uArgErr; + + VariantInit( &RetVal ); + memset( (LPBYTE) &excep, 0, sizeof( excep ) ); + + cMember = AnsiToWide( hb_parc( 2 ) ); + nOleError = pDisp->lpVtbl->GetIDsOfNames( pDisp, &IID_NULL, + ( LPVOID ) &cMember, 1, + LOCALE_USER_DEFAULT, &lDispID ); + hb_xfree( cMember ); + + if ( nOleError == S_OK ) + { + GetParams( &dParams ); + nOleError = pDisp->lpVtbl->Invoke( pDisp, + lDispID, + &IID_NULL, + LOCALE_USER_DEFAULT, + DISPATCH_PROPERTYGET, + &dParams, + &RetVal, + &excep, + &uArgErr ); + + FreeParams( &dParams ); + } + + RetValue(); + +} + +HB_FUNC( OLEERROR ) +{ + hb_retnl( (LONG) nOleError ); +} + +HB_FUNC( OLEISOBJECT ) +{ + hb_retl( RetVal.n1.n2.vt == VT_DISPATCH ); +} + +HB_FUNC( OLEUNINITIALIZE ) +{ + if( lInitialized ) + OleUninitialize(); + lInitialized = 0; +} + +HB_FUNC( OLE2TXTERROR ) +{ + switch ( (LONG) 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( GETOLEOBJECT ) +{ + BSTR wCLSID; + IID ClassID, iid; + LPIID riid = (LPIID) &IID_IDispatch; + IDispatch *pDisp = NULL; + IUnknown *pUnk = NULL; + char *cOleName = hb_parc( 1 ); + + nOleError = S_OK; + + wCLSID = (BSTR) AnsiToWide( (LPSTR)cOleName ); + + if ( cOleName[ 0 ] == '{' ) + { + nOleError = CLSIDFromString( wCLSID, (LPCLSID) &ClassID ); + } + else + { + 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 ); + nOleError = CLSIDFromString( wCLSID, &iid ); + hb_xfree( wCLSID ); + } + else + { + memcpy( ( LPVOID ) &iid, cID, sizeof( iid ) ); + } + + riid = &iid; + } + + if ( nOleError == S_OK ) + { + nOleError = GetActiveObject( &ClassID, NULL, &pUnk ); + + if ( nOleError == S_OK ) + { + nOleError = pUnk->lpVtbl->QueryInterface( pUnk, riid, (void **) &pDisp ); + } + } + + hb_retnl( ( LONG ) pDisp ); +} + +HB_FUNC( MESSAGEBOX ) +{ + hb_retni( MessageBox( ( HWND ) hb_parnl( 1 ), hb_parc( 2 ), hb_parc( 3 ), hb_parni( 4 ) ) ); +} diff --git a/harbour/contrib/ole/oleauto.prg b/harbour/contrib/ole/oleauto.prg new file mode 100644 index 0000000000..c14879de99 --- /dev/null +++ b/harbour/contrib/ole/oleauto.prg @@ -0,0 +1,221 @@ +/* + * $Id$ + */ + +/* + * Harbour Project source code: + * OLE library + * + * Copyright 2000,2003 José F. Giménez (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. + * + */ + + +#include "HBClass.ch" + + +CLASS TOleAuto + + 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 ) + +ENDCLASS + +//-------------------------------------------------------------------- + +METHOD New( uObj ) CLASS TOleAuto + + IF ValType( uObj )="C" + ::hObj := CreateOleObject( uObj ) + ELSE + ::hObj := uObj + ENDIF + +RETURN Self + +METHOD GetActiveObject( cClass ) CLASS TOleAuto + + IF ValType( cClass ) = 'C' + ::hObj := GetOleObject( cClass ) + // ::cClassName := cClass + ELSE + MessageBox( 0,"Invalid parameter type to constructor TOleAuto():GetActiveObject()!", "OLE Interface",0 ) + ::hObj := 0 + 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" + OLEShowException() + RETURN Self + ELSEIF OleError() != 0 + MessageBox( 0,cMethod + ": " + Ole2TxtError(), "OLE Error",0 ) + ENDIF + +RETURN uObj + +//-------------------------------------------------------------------- + +METHOD Set( cProperty, uParam1, uParam2, uParam3, uParam4, uParam5, uParam6 ) CLASS TOleAuto + + LOCAL uObj + + 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 + MessageBox( 0,cProperty + ": " + Ole2TxtError(), "OLE Error",0 ) + 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 + MessageBox( 0,cProperty + ": " + Ole2TxtError(), "OLE Error",0 ) + ENDIF + ENDIF + +RETURN uObj + +//-------------------------------------------------------------------- + +METHOD OnError( uParam1, uParam2, uParam3, uParam4, uParam5, uParam6 ) CLASS TOleAuto + + LOCAL cMsg := __GetMessage() + + LOCAL uObj + + IF LEFT( cMsg, 1 ) == '_' + ::Set( SUBS( cMsg, 2 ), uParam1, uParam2, uParam3, uParam4, uParam5, uParam6 ) + ELSE + uObj := ::Get( cMsg, uParam1, uParam2, uParam3, uParam4, uParam5, uParam6 ) + ENDIF + +RETURN uObj + +EXIT PROCEDURE OLEEXIT + + OLEUninitialize() + +RETURN \ No newline at end of file