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 | 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 ; }
