As a special gift from Santa (thanks Jose Luis!) here you have it to start using it. It has been tested with Harbour in PC and Pocket PC. Your feedback is welcome
Code: Select all | Expand
#include "fivewin.ch"#include "dbinfo.ch"function main()local o, x, nSec, n := 0, a[100], bREQUEST 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 //&&,DBFCDXREQUEST DBFFPTRDDSETDEFAULT("DBFCDX")SET AUTOPEN OFFSET DELETED ONSET CENTURY ONSET EPOCH TO( Year(Date())-50 )SET DATE BRITISH // Formato dd-mm-aaaaSET EXCLUSIVE OFFSET SOFTSEEK OFFHB_LangSelect('ES')HB_SetCodePage("ESMWIN") // Para ordenación (arrays, cadenas, etc..)msginfo("Iniciamos")o := xDatabase() // Nueva clase derivada de tDatabase de fivewino: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 )nextMsginfo(Seconds()-nSec, "Test de lectura de datos")// Test de velocidad en lectura con movimientosnSec := Seconds()for x=1 to 10000 o:Gotop() Do while !o:Eof() uFunc( o:Codpro ) o:Skip() EnddonextMsginfo(Seconds()-nSec, "Test de lectura")// Test de velocidad en EscrituranSec := Seconds()for x=1 to 10000 o:Gotop() Do while !o:Eof() o:Codpro := "Proba" + Alltrim(Str(x)) o:Skip() EnddonextMsginfo(Seconds()-nSec, "Test de escritura")return NILFUNCTION 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 )ENDCLASSMETHOD 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 endifreturn SelfMETHOD _FieldGet( nPos ) CLASS xDataBase if ::lBuffer //return ::aBuffer[ nPos ] Return HB_HVALUEAT( ::aBuffer, nPos ) else return ( ::nArea )->( FieldGet( nPos ) ) endifreturn 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 endifreturn nilMETHOD Load() CLASS xDataBase local n if ::lBuffer for n = 1 to ( ::cAlias )->( FCount() ) ::aBuffer[ ::aFldNames[n] ] := ( ::cAlias )->( FieldGet( n ) ) next if ::lOemAnsi ::OemToAnsi() endif endifreturn 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 endifreturn .f.METHOD Blank() CLASS XDataBase LOCAL a := HB_HKEYS( ::aBuffer ) if ::lBuffer AEval( a, { |u,i| HB_HVALUEAT( ::aBuffer, i, uValBlank( u )) } ) endifreturn .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 nextreturn nilMETHOD 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 endifreturn 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 endifreturn 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 ; }
