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

2003-04-15 13:10 UTC+0300 Alexander Kresin <alex@belacy.belgorod.su>

Browse Source
This commit is contained in:
Alexander S.Kresin
2003-04-15 09:12:31 +00:00
parent ff78e1b3f0
commit 4b6f2250df
6 changed files with 1051 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

11
harbour/ChangeLog
View File

@@ -8,6 +8,17 @@
2002-12-01 23:12 UTC+0100 Foo Bar <foo.bar@foobar.org>
*/
2003-04-15 13:10 UTC+0300 Alexander Kresin <alex@belacy.belgorod.su>
+ 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 <jfgimenez@wanadoo.es>,
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 <dholm@jsd-llc.com>
* source/common/hbgete.c
! Added #ifdef to allow OS/2 GCC to use PSZ and OS/2 VAC++ to use PCSZ for EnvValue.

9
harbour/contrib/ole/bldtest.bat Normal file
View File

@@ -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

24
harbour/contrib/ole/build32.bat Normal file
View File

@@ -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

171
harbour/contrib/ole/hbtest.prg Normal file
View File

@@ -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 ) ) + ;
"<contacto" + LTRIM( STR( i, 2 ) ) + "@servidor.com>" )
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

615
harbour/contrib/ole/ole2.c Normal file
View File

@@ -0,0 +1,615 @@
/*
* $Id$
*/
/*
* Harbour Project source code:
* OLE library
*
* Copyright 2000,2003 José F. Giménez (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 *
* *
\************************************************************************/
#include <Windows.h>
#include <Ole2.h>
#include <HBdate.h>
#include <hbvm.h>
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 ) ) );
}

221
harbour/contrib/ole/oleauto.prg Normal file
View File

@@ -0,0 +1,221 @@
/*
* $Id$
*/
/*
* Harbour Project source code:
* OLE library
*
* Copyright 2000,2003 José F. Giménez (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.
*
*/
#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