Como un regalo especial de Santa Claus (gracias Jose Luis!) aqui la teneis para empezar a usarla. Ha sido probada con Harbour en PC y en el Pocket PC. Se agradecen vuestras pruebas y resultados
Code: Select all
#include "fivewin.ch"
#include "dbinfo.ch"
function main()
local o, x, nSec, n := 0, a[100], b
REQUEST HB_LANG_ES // Para establecer español para Mensajes, fechas, etc..
REQUEST HB_CODEPAGE_ESMWIN // Para establecer código de página a Español
(Ordenación, etc..)
REQUEST DBFCDX //&&,DBFCDX
REQUEST DBFFPT
RDDSETDEFAULT("DBFCDX")
SET AUTOPEN OFF
SET DELETED ON
SET CENTURY ON
SET EPOCH TO( Year(Date())-50 )
SET DATE BRITISH // Formato dd-mm-aaaa
SET EXCLUSIVE OFF
SET SOFTSEEK OFF
HB_LangSelect('ES')
HB_SetCodePage("ESMWIN") // Para ordenación (arrays, cadenas, etc..)
msginfo("Iniciamos")
o := xDatabase() // Nueva clase derivada de tDatabase de fivewin
o:New( "CLI01.dbf")
o:lShared := .F.
o:Open()
o:lBuffer := .f.
nSec := Seconds()
// Test de velocidad en lectura de datos. Ahorro aproximado del 50%
nSec := Seconds()
for x=1 to 1000000
uFunc( o:Codpro )
next
Msginfo(Seconds()-nSec, "Test de lectura de datos")
// Test de velocidad en lectura con movimientos
nSec := Seconds()
for x=1 to 10000
o:Gotop()
Do while !o:Eof()
uFunc( o:Codpro )
o:Skip()
Enddo
next
Msginfo(Seconds()-nSec, "Test de lectura")
// Test de velocidad en Escritura
nSec := Seconds()
for x=1 to 10000
o:Gotop()
Do while !o:Eof()
o:Codpro := "Proba" + Alltrim(Str(x))
o:Skip()
Enddo
next
Msginfo(Seconds()-nSec, "Test de escritura")
return NIL
FUNCTION uFunc(u);Return NIL
////////////////////////////////////////////////////////////////////////////
/
CLASS xDatabase FROM tDatabase
METHOD SetArea()
METHOD Load()
METHOD CancelUpdate() INLINE ::lBuffer := .F.
MESSAGE FieldGet METHOD _FieldGet( nField )
MESSAGE FieldPut METHOD _FieldPut( nField, uVal )
METHOD Blank()
METHOD Modified()
METHOD SaveBuff()
MESSAGE OemToAnsi METHOD _OemToAnsi()
METHOD HashAddMember()
ERROR HANDLER ONERROR( uParam1 )
ENDCLASS
METHOD SetArea( nWorkArea ) CLASS xDatabase
local n, oClass, aDatas := {}, aMethods := {}
::nArea = nWorkArea
::cAlias = Alias( nWorkArea )
::cFile = Alias( nWorkArea )
if ::Used()
::cFile = ( nWorkArea )->( DbInfo( DBI_FULLPATH ) )
::cDriver = ( nWorkArea )->( RddName() )
::lShared = ( nWorkArea )->( DbInfo( DBI_SHARED ) )
#ifdef __HARBOUR__
::lReadOnly = ( nWorkArea )->( DbInfo( DBI_ISREADONLY ) )
#else
DEFAULT ::lReadOnly := .f.
#endif
DEFAULT ::lBuffer := .t.
DEFAULT ::lOemAnsi := .f.
DEFAULT ::bNetError := { || MsgStop( "Record in use", "Please, retry"
) }
::aStruct = ( ::cAlias )->( DbStruct() )
::aFldNames = {}
::aBuffer := hb_HSetCaseMatch( hb_Hash(), .F. )
for n = 1 to ( ::cAlias )->( FCount() )
AAdd( ::aFldNames, ( ::cAlias )->( FieldName( n ) ) )
::HashAddMember( {( ::cAlias )->( FieldName( n ) )},;
( ::cAlias )->( FieldType( n ) ),;
( ::cAlias )->( FieldGet( n ) ),;
::aBuffer )
next
hb_HSetAutoAdd( ::aBuffer, .f. )
if ::lOemAnsi
::OemToAnsi()
endif
#ifdef __XPP__
if ClassObject( Alias() ) == nil
ClassCreate( Alias(), { TDataBase() }, aDatas, aMethods )
// else
// ::this = Self
endif
#endif
endif
return Self
METHOD _FieldGet( nPos ) CLASS xDataBase
if ::lBuffer
//return ::aBuffer[ nPos ]
Return HB_HVALUEAT( ::aBuffer, nPos )
else
return ( ::nArea )->( FieldGet( nPos ) )
endif
return nil
//--------------------------------------------------------------------------
-//
METHOD _FieldPut( nPos, uValue ) CLASS xDataBase
local lLocked := .f.
if ::lBuffer
//::aBuffer[ nPos ] := uValue
HB_HVALUEAT( ::aBuffer, nPos, uValue )
else
if ::lShared
if ! ::lReadOnly
if ::IsRecLocked( ::RecNo() ) .or. ( lLocked := ::RecLock(
::RecNo() ) )
( ::nArea )->( FieldPut( nPos, uValue ) )
if lLocked
::Commit()
::RecUnLock( ::RecNo() )
endif
else
if ! Empty( ::bNetError )
return Eval( ::bNetError, Self )
endif
endif
endif
else
( ::nArea )->( FieldPut( nPos, uValue ) )
endif
endif
return nil
METHOD Load() CLASS xDataBase
local n
if ::lBuffer
for n = 1 to ( ::cAlias )->( FCount() )
::aBuffer[ ::aFldNames[n] ] := ( ::cAlias )->( FieldGet( n ) )
next
if ::lOemAnsi
::OemToAnsi()
endif
endif
return nil
//--------------------------------------------------------------------------
--//
METHOD Modified() CLASS XDataBase
local n
if ::lBuffer
for n := 1 to Len( ::aFldNames )
if ! ( ::cAlias )->( FieldGet( n ) ) == ::aBuffer[ ::aFldNames[n] ]
return .t.
endif
next
endif
return .f.
METHOD Blank() CLASS XDataBase
LOCAL a := HB_HKEYS( ::aBuffer )
if ::lBuffer
AEval( a, { |u,i| HB_HVALUEAT( ::aBuffer, i, uValBlank( u )) } )
endif
return .f.
METHOD _OemToAnsi() CLASS XDataBase
local n
for n = 1 to Len( ::aFldNames )
if ValType( ::aBuffer[ ::aFldNames[n] ] ) == "C"
::aBuffer[ ::aFldNames[n] ] := OemToAnsi( ::aBuffer[ ::aFldNames[n]
] )
endif
next
return nil
METHOD SaveBuff() CLASS XDataBase
local n
if ::lBuffer
for n := 1 to Len( ::aFldNames )
if ::lOemAnsi .and. ValType( ::aBuffer[ ::aFldNames[n] ] ) == "C"
( ::nArea )->( FieldPut( n, AnsiToOem( ::aBuffer[ ::aFldNames[n]
] ) ) )
else
( ::nArea )->( FieldPut( n, ::aBuffer[ ::aFldNames[n] ] ) )
endif
next
endif
return nil
****************************************************************************
************************************
* Descripción :
* Parámetros : Ninguno
* Fecha : 06/21/06
* Autor : Equipo de desarrollo de Aicom
****************************************************************************
************************************
METHOD HashAddMember( aName, cType, uInit, oObj ) CLASS xDataBase
//--------------------------------------------------------------------------
------------------------------------
local cName
if !( cType == nil )
switch Upper( Left( cType, 1 ) )
case "S" // STRING
if uInit == nil
uInit := ""
endif
exit
case "N" // NUMERIC
if uInit == nil
uInit := 0
endif
exit
case "L" // LOGICAL
if uInit == nil
uInit := .f.
endif
exit
case "D" // DATE
if uInit == nil
uInit := CtoD( "" )
endif
exit
case "C" // CODEBLOCK
if uInit == nil
uInit := { || nil }
endif
exit
case "A" // ARRAY
if uInit == nil
uInit := {}
endif
exit
end switch
endif
return NIL
#pragma BEGINDUMP
#include "windows.h"
#include "hbapi.h"
#include "hbapierr.h"
#include "hbapiitm.h"
#include "hbapicls.h"
#include "hbvm.h"
#include "hbdate.h"
#include "hboo.ch"
#include "hbapirdd.h"
#include "hbstack.h"
#include "hbapilng.h"
char * AicomGetmessage();
HB_FUNC_STATIC( XDATABASE_ONERROR )
{
char * cMessage = AicomGetmessage() ;
PHB_ITEM pSelf = hb_stackSelfItem();
BOOL bBuffer = hb_itemGetL( hb_objSendMsg(pSelf, "LBUFFER",
0) );
PHB_ITEM pValue = hb_param(1,HB_IT_ANY);
const char *cKey = ( *cMessage == '_' ? (cMessage+1) :
cMessage ) ;
if( bBuffer)
{
PHB_ITEM pHash = hb_objSendMsg(pSelf,"ABUFFER",0);
PHB_ITEM pKey = hb_itemPutC( hb_itemNew(NULL), cKey );
if( *cMessage == '_' )
{
// Con esto asignamos un valor al buffer
if( pHash && pKey && pValue )
{
hb_hashAdd( pHash, pKey, pValue );
hb_itemRelease( pKey );
}
else
hb_errRT_BASE( EG_ARG, 1123, NULL,
HB_ERR_FUNCNAME, HB_ERR_ARGS_BASEPARAMS );
} else
{
// Esto devuelve el valor del buffer
PHB_ITEM pDest = hb_hashGetItemPtr( pHash, pKey,
HB_HASH_AUTOADD_ACCESS );
hb_itemRelease( pKey );
if(pDest)
hb_itemReturn(pDest);
else
hb_errRT_BASE( EG_BOUND, 1132, NULL,
hb_langDGetErrorDesc( EG_ARRACCESS ), 2, pHash, pValue );
}
}
else
{
int iAreaAnt = hb_rddGetCurrentWorkAreaNumber();
// Area anterior
int iAreaAct = hb_itemGetNI( hb_objSendMsg(pSelf,
"NAREA", 0 ) ); // Buscamos actual
AREAP pArea = ( AREAP )
hb_rddGetCurrentWorkAreaPointer(); // Necesitamos pArea
USHORT uiField = hb_rddFieldIndex( pArea, cKey );
// FieldPos ( cFieldName )
hb_rddSelectWorkAreaNumber( iAreaAct ) ;
// Seleccionamos area actual
if(uiField)
{
if( *cMessage == '_' )
{
// Asignamos el valor
if( pValue && !HB_IS_NIL( pValue ) )
{
if( SELF_PUTVALUE( pArea, uiField,
pValue ) == SUCCESS )
{
hb_itemReturn( pValue );
}
}
} else
{
// Devolvemos el valor del campo
PHB_ITEM pItem = hb_itemNew( NULL );
if( pArea ) // && uiField )
{
SELF_GETVALUE( pArea, uiField, pItem
);
}
hb_itemReturnRelease( pItem );
}
hb_rddSelectWorkAreaNumber( iAreaAnt ) ;
// Seleccionamos area anterior
} else
{
hb_errRT_DBCMD(( *cMessage == '_' ? 1005 : 1004 ),
0, "Field not found", cKey );
}
}
}
char * AicomGetmessage()
{
// Thanks to Przemek
long lOffset = hb_stackBaseProcOffset( 0 );
char * cMessage = (char *)hb_itemGetSymbol( hb_stackItem( lOffset ) )->szName;
return cMessage ;
}
