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

2010-05-29 10:29 UTC+0200 Przemyslaw Czerpak (druzus/at/priv.onet.pl)

Browse Source 
* harbour/contrib/hbwin/olecore.c
    ! fixed old bug in passing parameters by reference to OLE objects
      (they were cleared in reverted order so half of the complex variants
      were cleared before coping to HVM items)

  + harbour/contrib/hbwin/tests/oletst4.prg
  + harbour/contrib/hbwin/tests/olesrv4.hbp
  + harbour/contrib/hbwin/tests/olesrv4.prg
  + harbour/contrib/hbwin/tests/oletst4.hbp
    + added  example of OLE server returning to client HVM objects as
      OLE object and also some other values using parameters passed by
      reference with client code.
      Remember about registering the server by 'regsvr32 olesrv2.dll'
      before testing the client code.
This commit is contained in:
Przemyslaw Czerpak
2010-05-29 08:30:15 +00:00
parent f17f4e7d66
commit 05db043943
6 changed files with 153 additions and 7 deletions
Download Patch File Download Diff File Expand all files Collapse all files

16
harbour/ChangeLog
View File

@@ -17,6 +17,22 @@
past entries belonging to author(s): Viktor Szakats.
*/
2010-05-29 10:29 UTC+0200 Przemyslaw Czerpak (druzus/at/priv.onet.pl)
* harbour/contrib/hbwin/olecore.c
! fixed old bug in passing parameters by reference to OLE objects
(they were cleared in reverted order so half of the complex variants
were cleared before coping to HVM items)
+ harbour/contrib/hbwin/tests/oletst4.prg
+ harbour/contrib/hbwin/tests/olesrv4.hbp
+ harbour/contrib/hbwin/tests/olesrv4.prg
+ harbour/contrib/hbwin/tests/oletst4.hbp
+ added example of OLE server returning to client HVM objects as
OLE object and also some other values using parameters passed by
reference with client code.
Remember about registering the server by 'regsvr32 olesrv2.dll'
before testing the client code.
2010-05-29 04:28 UTC+0200 Viktor Szakats (harbour.01 syenar.hu)
* utils/hbmk2/hbmk2.prg
! Fixed silly variable initialization bug after last commit.

15
harbour/contrib/hbwin/olecore.c
View File

@@ -1126,7 +1126,8 @@ HB_BOOL hb_oleDispInvoke( PHB_SYMB pSym, PHB_ITEM pObject, PHB_ITEM pParam,
for( i = 1, ii = 0; i <= iCount; i++ )
{
if( pParams->rgvarg[ iCount - i ].n1.n2.vt & VT_BYREF && ii < iRefs )
if( ( pParams->rgvarg[ iCount - i ].n1.n2.vt & VT_BYREF ) &&
( ii < iRefs ) )
{
refArray[ ii ].variant = &pParams->rgvarg[ iCount - i ];
hb_oleVariantToItem( refArray[ ii ].item, refArray[ ii ].variant );
@@ -1170,9 +1171,9 @@ static void GetParams( DISPPARAMS * dispparam )
if( uiArgCount > 0 )
{
uiRefs = 0;
for( uiArg = 0; uiArg < uiArgCount; uiArg++ )
for( uiArg = 1; uiArg <= uiArgCount; uiArg++ )
{
if( HB_ISBYREF( uiArg + 1 ) )
if( HB_ISBYREF( uiArg ) )
uiRefs++;
}
@@ -1206,14 +1207,14 @@ static void PutParams( DISPPARAMS * dispparam )
PHB_ITEM pItem = NULL;
UINT uiArg;
for( uiArg = 1; uiArg <= dispparam->cArgs; uiArg++ )
for( uiArg = 0; uiArg < dispparam->cArgs; uiArg++ )
{
if( HB_ISBYREF( uiArg ) )
if( HB_ISBYREF( dispparam->cArgs - uiArg ) )
{
if( !pItem )
pItem = hb_itemNew( NULL );
hb_oleVariantToItem( pItem, &dispparam->rgvarg[ dispparam->cArgs - uiArg ] );
hb_itemParamStoreForward( ( HB_USHORT ) uiArg, pItem );
hb_oleVariantToItem( pItem, &dispparam->rgvarg[ uiArg ] );
hb_itemParamStoreForward( ( HB_USHORT ) ( dispparam->cArgs - uiArg ), pItem );
VariantClear( pRefs );
pRefs++;
}

9
harbour/contrib/hbwin/tests/olesrv4.hbp Normal file
View File

@@ -0,0 +1,9 @@
#
# $Id: olesrv3.hbp 14596 2010-05-25 23:44:42Z vszakats $
#
-hbdynvm
../hbolesrv.hbc
olesrv4.prg

66
harbour/contrib/hbwin/tests/olesrv4.prg Normal file
View File

@@ -0,0 +1,66 @@
/*
* $Id$
*/
/*
* Harbour Project source code:
* demonstration/test code for OLE server returning to client
* HVM objects as OLE object. It's also test for parameters
* passed by reference.
*
* Copyright 2010 Przemyslaw Czerpak <druzus / at / priv.onet.pl>
* www - http://www.harbour-project.org
*
*/
#define CLS_Name "MyOleObjServer"
#define CLS_ID "{23245C3F-4487-404B-985F-E33886698D23}"
#include "hbclass.ch"
PROCEDURE DllMain()
WIN_OleServerInit( CLS_ID, CLS_Name, OleObjServer():new() )
RETURN
CREATE CLASS OleObjServer
METHOD timer
METHOD info
METHOD ref
ENDCLASS
METHOD timer() CLASS OleObjServer
RETURN timerCls():new()
METHOD info() CLASS OleObjServer
RETURN infoCls():new()
METHOD ref( p1, p2, p3, p4, p5, p6, p7 ) CLASS OleObjServer
p1 := date()
p2 := hb_datetime()
p3 := .t.
p4 := { "A", "B", "C" }
p5 := timerCls():new()
p6 := 123.456
p7 := "text"
RETURN "DONE"
CREATE CLASS timerCls
MESSAGE date EXTERN date
MESSAGE time EXTERN time
MESSAGE now EXTERN hb_datetime
ENDCLASS
CREATE CLASS infoCls
MESSAGE os EXTERN os
MESSAGE ver EXTERN version
MESSAGE compiler EXTERN hb_compiler
MESSAGE build EXTERN hb_builddate
ENDCLASS
ANNOUNCE GT_SYS
REQUEST HB_GT_GUI_DEFAULT

7
harbour/contrib/hbwin/tests/oletst4.hbp Normal file
View File

@@ -0,0 +1,7 @@
#
# $Id: oletst3.hbp 14594 2010-05-25 22:23:11Z vszakats $
#
oletst4.prg
-cflag={watcom}-6r

47
harbour/contrib/hbwin/tests/oletst4.prg Normal file
View File

@@ -0,0 +1,47 @@
/*
* $Id$
*/
/*
* Harbour Project source code:
* demonstration/test client code for OLE server returning to client
* HVM objects as OLE object. It's also test for parameters
* passed by reference.
*
* Copyright 2010 Przemyslaw Czerpak <druzus / at / priv.onet.pl>
* www - http://www.harbour-project.org
*/
PROCEDURE Main()
LOCAL oObject, oTime, oInfo
LOCAL p1, p2, p3, p4, p5, p6, p7
oObject := win_OleCreateObject( "MyOleObjServer" )
IF !Empty( oObject )
oTime := oObject:timer()
? "TIMER:"
? " date:", oTime:date
? " time:", oTime:time
? " now:", oTime:now
oInfo := oObject:info()
? "INFO:"
? " os:", oInfo:os
? " ver:", oInfo:ver
? " compiler:", oInfo:compiler
? " build:", oInfo:build
?
? "REF:", oObject:ref( @p1, @p2, @p3, @p4, @p5, @p6, @p7 )
? " p1:", hb_valToExp( p1 )
? " p2:", hb_valToExp( p2 )
? " p3:", hb_valToExp( p3 )
? " p4:", hb_valToExp( p4 )
? " p5:", p5:className() // hb_valToExp( p5 )
? " p6:", hb_valToExp( p6 )
? " p7:", hb_valToExp( p7 )
ELSE
? "Can not access 'MyOleObjServer' OLE server."
ENDIF
WAIT
RETURN