// Exemplos no FiveWin Brasil:
/*
<!-- m --><a class="postlink" href="http://fivewin.com.br/index.php?/topic/21090-excel-dbf-resolvido/">http://fivewin.com.br/index.php?/topic/ ... resolvido/</a><!-- m -->
<!-- m --><a class="postlink" href="http://fivewin.com.br/index.php?/topic/21773-excel-ler-o-arquivo-e-transferir-para-um-dbf-resolvido/">http://fivewin.com.br/index.php?/topic/ ... resolvido/</a><!-- m -->
*/
// By Manuel Mercado
#include "FiveWin.ch"
#include "TSBrowse.CH"
//#include "TSButton.CH"
#define CLR_HBROWN nRGB( 205, 192, 176 )
REQUEST DBFCDX
STATIC oWnd, aRedir, nFrom, nDest
//--------------------------------------------------------------------------------------------------------------------//
Function Main()
Local oMenu, oIco
SET DATE BRITISH
SET EPOCH TO Year( Date() ) - 70
MENU oMenu
MENUITEM "Archivo"
MENU
MENUITEM "Create &Excel Sheet" ACTION fExcelDbf( ,, .F.)
MENUITEM "Create &Database" ACTION fExcelDbf()
MENUITEM "E&xit" ACTION oWnd:End()
ENDMENU
MENUITEM "E&xit" ACTION oWnd:End()
ENDMENU
DEFINE WINDOW oWnd MENU oMenu TITLE "From Excel To Dbf or Visceversa"
ACTIVATE WINDOW oWnd MAXIMIZED ON INIT fExcelDbf()
Return Nil
//--------------------------------------------------------------------------------------------------------------------//
Function fExcelDbf( cXls, cDbf, lXls )
Local oDlg, aCtl[ 9 ], lActivate, oFont, nVer, ;
nAvance := 0
Default cXls := Padr( "Libro1.xls", 60 ), ;
cDbf := Padr( "Base1.dbf", 60 ), ;
lXls := .T.
nVer := If( lXls, 1, 2 )
lActivate := lXls
DEFINE FONT oFont NAME "MS Sans Serif" SIZE 0, -11
DEFINE DIALOG oDlg FROM 0, 0 TO 202, 380 PIXEL FONT oFont ;
COLORS CLR_BLACK, CLR_HBROWN ;
TITLE "Excel/Database/Excel"
oDlg:nStyle := nOr( oDlg:nStyle, 4 )
@ 11, 6 SAY aCtl[ 1 ] PROMPT "Database" OF oDlg ;
FONT oFont UPDATE ;
COLORS CLR_BLACK, CLR_HBROWN SIZE 39, 9 PIXEL
@ 11, 45 GET aCtl[ 2 ] VAR cDbf OF oDlg SIZE 141, 10 PIXEL COLOR CLR_BLACK, CLR_WHITE FONT oFont ;
ACTION ( cDbf := PadR( cGetFileName( .F. ), 60 ), aCtl[ 2 ]:Refresh() ) Bitmap "Find16"
@ 27, 6 SAY aCtl[ 3 ] PROMPT "Excel File" OF oDlg ;
FONT oFont UPDATE ;
COLORS CLR_BLACK, CLR_HBROWN SIZE 39, 9 PIXEL
@ 27, 45 GET aCtl[ 4 ] VAR cXls OF oDlg SIZE 141, 10 PIXEL COLOR CLR_BLACK, CLR_WHITE FONT oFont ;
ACTION ( cXls := PadR( cGetFileName(), 60 ), aCtl[ 4 ]:Refresh() ) Bitmap "Find16"
@ 43, 31 CheckBox aCtl[ 5 ] VAR lActivate OF oDlg ;
PROMPT "Abrir Excel" FONT oFont UPDATE SIZE 50, 16 PIXEL
@ 39, 82 Radio aCtl[ 6 ] Var nVer PROMPT "Xls/Dbf", "Dbf/Xls" Of oDlg Size 200, 10 Pixel
// ALIGN DT_CENTER ;
// COLORS CLR_BLACK, CLR_HBROWN, CLR_WHITE, CLR_GRAY, ;
// CLR_BLACK
@ 66, 36 BUTTON aCtl[ 7 ] PROMPT "&Ok" OF oDlg ;
ACTION ( If( nVer == 1, fXls2Dbf( cXls, cDbf, aCtl[ 9 ] ), ;
fDbf2Xls( cXls, cDbf, aCtl[ 9 ], lActivate ) ), oDlg:End() ) ;
FONT oFont SIZE 38, 12 PIXEL
@66, 99 BUTTON aCtl[ 8 ] PROMPT "&Exit" OF oDlg ;
ACTION oDlg:End() ;
FONT oFont SIZE 38, 12 PIXEL
@ 86, 6 METER aCtl[ 9 ] VAR nAvance OF oDlg TOTAL 100 ;
PROMPT "Avance" SIZE 178, 12 PIXEL FONT oFont ;
COLORS CLR_HBROWN, CLR_BLACK ;
BARCOLOR CLR_HBLUE, CLR_YELLOW
ACTIVATE DIALOG oDlg CENTERED VALID ( oFont:End(), .T. )
Return Nil
//--------------------------------------------------------------------------------------------------------------------//
Static Function fXls2Dbf( cXls, cDbf, oMtr, nTitRow, nDatRow )
Local oExcel, oSheet, nRows, nCols, nRow, nCol, uData, nEle, nStep, ;
nAvance := 0, ;
aCampos := {}
Default aRedir := {}
If Empty( cXls )
Return Nil
EndIf
CursorWait()
cXls := UppCap( StrTran( Upper( AllTrim( cXls ) ), ".XLS" ) + ".XLS" )
Default cDbf := UppCap( StrTran( Upper( cXls ), ".XLS" ) ), ;
nTitRow := 1, ;
nDatRow := 2
If ! File( Lfn2Sfn( cXls ) )
CursorArrow()
MsgStop( "Unexist File", cXls )
Return Nil
EndIf
oExcel := TOleAuto():New( "Excel.Application" )
oExcel:WorkBooks:Open( cXls )
oSheet := oExcel:Get( "ActiveSheet" )
nRows := oSheet:UsedRange:Rows:Count()
nCols := oSheet:UsedRange:Columns:Count()
oMtr:cText := "Creando Base de Datos"
oMtr:nTotal := nCols + ( nCols * nRows )
oMtr:Set( nAvance )
oMtr:Refresh()
nStep := Max( 1, Int( oMtr:nTotal * .03 ) )
For nCol := 1 To nCols
If ValType( oSheet:Cells( nDatRow, nCol ):Value ) = "C"
AAdd( aCampos, { PadR( oSheet:Cells( nTitRow, nCol ):Value, 10 ), "C", 80, 0 } )
ElseIf ValType( oSheet:Cells( nDatRow, nCol ):Value ) = "N"
AADD( aCampos, { PadR( oSheet:Cells( nTitRow, nCol ):Value, 10 ), "N", 13, 0 } )
ElseIf ValType( oSheet:Cells( nDatRow, nCol ):Value ) = "L"
AADD( aCampos, { PadR( oSheet:Cells( nTitRow, nCol ):Value, 10 ), "L", 1, 0 } )
ElseIf ValType( oSheet:Cells( nDatRow, nCol ):Value ) = "D"
AADD( aCampos, { PadR( oSheet:Cells( nTitRow, nCol ):Value, 10 ), "D", 8, 0 } )
Else
AADD( aCampos, { PadR( oSheet:Cells( nTitRow, nCol ):Value, 10 ), "C", 80, 0 } )
ENDIf
oMtr:Set( ++ nAvance )
SysRefresh()
Next
CursorArrow()
If Empty( aCampos := aEditCampos( aCampos, cDbf ) )
oExcel:Quit()
Return Nil
EndIf
CursorWait()
For nRow := 1 To Len( aCampos )
Next
DbCreate( cDbf, aCampos )
Use ( cDbf ) New
For nRow := nDatRow To nRows
APPEND BLANK
For nCol := 1 To nCols
uData := oSheet:Cells( nRow, nCol ):Value
nEle := aRedir[ AScan( aRedir, {|e| e[ 1 ] == nCol } ), 2 ]
If aCampos[ nEle, 2 ] == "C"
If ValType( uData ) == "N"
uData := Mask( uData,,, .F., .F., .F. )
Else
uData := VtoC( uData )
EndIf
ElseIf aCampos[ nEle, 2 ] == "N"
uData := VtoN( uData )
ElseIf aCampos[ nEle, 2 ] == "D"
uData := CtoD( VtoC( uData ) )
EndIf
FieldPut( nEle, uData )
If ( ++ nAvance % nStep ) == 0
oMtr:Set( nAvance )
EndIf
SysRefresh()
Next
Next
DbCloseArea()
oExcel:Quit()
oMtr:Set( oMtr:nTotal )
oMtr:Refresh()
CursorArrow()
Return Nil
//--------------------------------------------------------------------------------------------------------------------//
Static Function fDbf2Xls( cXls, cDbf, oMtr, lActivate, cInd, cDrv, cTitle )
Local oExcel, oSheet, oClip, oRange, nCol, cLet, nTotCol, nTotRow, nAvance, uData, ;
nRow := 1, ;
aCol := { 26, 52, 78, 104, 130, 156 }, ;
aLet := { "", "A", "B", "C", "D", "E" }, ;
lCdx := .F., ;
cText := ""
If Empty( cDbf )
Return Nil
EndIf
CursorWait()
cDbf := AllTrim( StrTran( Upper( cDbf ), ".DBF" ) )
cDbf += ".DBF"
cInd := If( Empty( cInd ), "", AllTrim( Upper( cInd ) ) )
If ! Empty( cInd )
If At( ".", cInd ) > 0
lCdx := "CDX" $ cInd
ElseIf File( cInd + ".CDX" )
lCdx := .T.
EndIf
EndIf
Default cDrv := If( lCdx, "DBFCDX", "DBFNTX" )
If ! File( Lfn2Sfn( cDbf ) )
CursorArrow()
MsgStop( "No Existe el Archivo", cDbf )
Return Nil
EndIf
If ! Empty( cInd )
Use cDbf Shared New VIA cDrv
Set Index To ( cInd )
Else
Use ( cDbf ) Shared New VIA cDrv
EndIf
nTotRow := If( ! Empty( cInd ) .and. lCdx, OrdKeyCount(), LastRec() )
nTotCol := Min( Fcount(), 156 )
If Empty( nTotRow )
DbCloseArea()
CursorArrow()
MsgStop( "Base de datos vacía", "Error" )
Return Nil
EndIf
oMtr:cText := "Creando hoja de Excel"
oMtr:nTotal := nTotRow + nTotCol
oMtr:Set( nAvance := 0 )
oMtr:Refresh()
oExcel := TOleAuto():New( "Excel.Application" )
oExcel:WorkBooks:Add()
oSheet := oExcel:Get( "ActiveSheet" )
cLet := aLet[ AScan( aCol, {|e| nTotCol <= e } ) ]
If ! Empty( cLet )
nEle := AScan( aLet, cLet ) - 1
cLet += Chr( 64 + nTotCol - aCol[ Max( 1, nEle ) ] )
Else
cLet := Chr( 64 + nTotCol )
EndIf
If ! Empty( cTitle )
cText += cTitle + Chr( 13 )
EndIf
For nCol := 1 To nTotCol
cText += UppCap( FieldName( nCol ) ) + Chr( 9 )
nAvance ++
oMtr:Set( nAvance )
SysRefresh()
Next
cText += Chr( 13 )
DbGoTop()
nStart := nRow := 1
While ! EoF()
For nCol := 1 To nTotCol
uData := FieldGet( nCol )
uData := If( ValType( uData )=="D", DtoC( uData ), If( ValType( uData )=="N", Str( uData ) , ;
If( ValType( uData )=="L", If( uData ,".T." ,".F." ), VtoC( uData ) ) ) )
cText += AllTrim( uData ) + Chr( 9 )
Next
cText += Chr( 13 )
nRow ++
IF Len( cText ) > 20000
oClip := TClipBoard():New()
oClip:Clear()
oClip:SetText( cText )
oRange := oSheet:Range( "A" + LTStr( nStart ) )
oRange:Select()
oSheet:Paste()
oClip:End()
cText := ""
nStart := nRow + 1
EndIf
DbSkip()
nAvance ++
oMtr:Set( nAvance )
SysRefresh()
EndDo
If ! Empty( cText )
oClip := TClipBoard():New()
oClip:Clear()
oClip:SetText( cText )
oRange := oSheet:Range( "A" + LTStr( nStart ) )
oRange:Select()
oSheet:Paste()
oClip:End()
EndIf
oSheet:Range( "A1:" + cLet + "1" ):Set( "HorizontalAlignment", 7 )
cRange := "A" + If( ! Empty( cTitle ), "3", "1" ) + ":" + cLet + LTStr( oSheet:UsedRange:Rows:Count() )
oSheet:Range( cRange ):Borders():LineStyle := 1
oSheet:Columns( "A:" + cLet ):AutoFit()
DbCloseArea()
If lActivate
oExcel:Visible := .T.
EndIf
oExcel:Quit()
oMtr:Set( oMtr:nTotal )
CursorArrow()
Return Nil
//--------------------------------------------------------------------------------------------------------------------//
Static Function aEditCampos( aCampos, cDbf )
Local oDlg, oBrw, oFont, cGet, cAnt, cSay, aCtl[ 10 ], oDrCur, nBase, nEle, ;
aDbf := aCampos, ;
lOk := .F., ;
lRenamed := .F., ;
lCopy := .F., ;
nAvance := 0, ;
aCla := { "C", "N", "D", "L", "M" }, ;
aTip := { "Alfanumérico", "Numérico", "Fecha", "Lógico", "Memo" }
aRedir := {}
cGet := cAnt := If( At( "\", cDbf ) > 0, cDbf, cFilePath( GetModuleFileName( GetInstance() ) ) + cDbf )
cSay := "Campo 1" + Space( 3 ) + Trim( aDbf[ 1, 1 ] )
For nEle := 1 To Len( aDbf )
AAdd( aRedir, { nEle, nEle } )
Next
DEFINE FONT oFont NAME "MS Sans Serif" SIZE 0, -8
DEFINE CURSOR oDrCur RESOURCE "Drag"
DEFINE DIALOG oDlg FROM 0, 0 TO 388, 380 PIXEL FONT oFont ;
STYLE nOr( WS_POPUP, WS_BORDER ) ;
COLOR CLR_BLACK, CLR_HBROWN
@ 0, 0 SAY aCtl[ 1 ] PROMPT "Crear Base de Datos" OF oDlg ;
SIZE 192, 9 PIXEL CENTER ;
COLOR CLR_WHITE, CLR_BLUE FONT oFont
@ 13, 20 Group aCtl[ 2 ] To 29, 192 OF oDlg LABEL "Guardar Como" ;
PIXEL
@ 19, 23 SAY aCtl[ 3 ] VAR cGet SIZE 142, 8 PIXEL OF oDlg BORDER
@ 51, 20 SAY aCtl[ 5 ] VAR cSay OF oDlg SIZE 148, 8 PIXEL ;
COLOR CLR_WHITE, 8323200 BORDER CENTER
@ 61, 20 BROWSE aCtl[ 6 ] ARRAY aDbf OF oDlg CELLED SIZE 148, 93 PIXEL ;
COLORS CLR_BLACK, CLR_WHITE, CLR_BLACK, CLR_HGRAY, CLR_WHITE, CLR_BLACK
aCtl[ 6 ]:bChange := { || cSay := "Campo" + Space( 1 ) + ;
LTStr( aCtl[ 6 ]:nAt ) + Space( 3 ) + ;
If( aCtl[ 6 ]:nAt > 0 .and. ;
Len( aCtl[ 6 ]:aArray ) > 0 .and. ;
! aCtl[ 6 ]:lAppendMode, ;
aCtl[ 6 ]:aArray[ aCtl[ 6 ]:nAt ][ 1 ], "" ), ;
aCtl[ 5 ]:Refresh() }
ADD COLUMN TO aCtl[ 6 ] DATA ARRAY ELM 1 TITLE "Nombre" ;
VALID { |uVar| ! Empty( uVar ) } PICTURE "@K!" ;
ALIGN DT_LEFT, DT_CENTER SIZE 80 PIXELS ;
POSTEDIT { || lRenamed := If( aCtl[ 6 ]:lChanged, .T., lRenamed ) } ;
EDITABLE MOVE DT_MOVE_RIGHT
ADD COLUMN TO aCtl[ 6 ] COMBOBOX TITLE "Tipo" ;
DATA ComboWBlock( aCtl[ 6 ], 2, 2, { aTip, aCla } ) ;
ALIGN DT_LEFT, DT_CENTER SIZE 70 PIXELS ;
EDITABLE MOVE DT_MOVE_NEXT ;
POSTEDIT { |v,o,c| c := o:aArray[ o:nAt, 2 ], o:aArray[ o:nAt, 3 ] := ;
If( c == "L", 1, If( c == "D", 8, o:aArray[ o:nAt, 3 ] ) ), ;
o:aArray[ o:nAt, 4 ] := If( c != "N", 0, o:aArray[ o:nAt, 4 ] ) }
ADD COLUMN TO aCtl[ 6 ] DATA ARRAY ELM 3 TITLE "Longitud" ;
WHEN ( aCtl[ 6 ]:aArray[ aCtl[ 6 ]:nAt, 2 ] $ "CN" ) ;
PICTURE "@K!" ALIGN DT_LEFT SIZE 55 PIXELS ;
EDITABLE MOVE DT_MOVE_NEXT
ADD COLUMN TO aCtl[ 6 ] DATA ARRAY ELM 4 TITLE "Decimales" ;
WHEN aCtl[ 6 ]:aArray[ aCtl[ 6 ]:nAt, 2 ] == "N" ;
VALID { |uVar| uVar <= 9 } ;
PICTURE "@K" ALIGN DT_RIGHT, DT_CENTER SIZE 65 PIXELS ;
EDITABLE MOVE DT_MOVE_NEXT
aCtl[ 6 ]:lNoHScroll := .T.
aCtl[ 6 ]:lNoExit := .T.
aCtl[ 6 ]:SetAppendMode( .T. )
aCtl[ 6 ]:SetDeleteMode( .T., .F. )
aCtl[ 6 ]:aDefault := { Space( 10 ), "C", 10, 0 }
aCtl[ 6 ]:bKeyDown := { |nKey| If( nKey = VK_INSERT, ( ASize( aCtl[ 6 ]:aArray, Len( aCtl[ 6 ]:aArray ) + 1 ), ;
AIns( aCtl[ 6 ]:aArray, aCtl[ 6 ]:nAt ), ;
aCtl[ 6 ]:aArray[ aCtl[ 6 ]:nAt ] := aCtl[ 6 ]:aDefault, ;
aCtl[ 6 ]:Refresh( .T. ) ), Nil ) }
aCtl[ 6 ]:oDragCursor := oDrCur
aCtl[ 6 ]:bDropOver := { |u,n| nDest := u[ 2 ]:GetTxtRow( n ), ;
fDropDrag( u[ 3 ], u[ 2 ]:GetTxtRow( n ), u[ 1 ], u[ 2 ] ) }
aCtl[ 6 ]:bDragBegin = { |nRow,nCol,nFlags,x| nFrom := x:nAt, SetDropInfo( { x:nAt, x, x:nRowPos } ) }
@158, 20 BUTTON aCtl[ 7 ] PROMPT "Crear" OF oDlg SIZE 40, 12 PIXEL ;
ACTION ( aDbf := aCtl[ 6 ]:aArray, lOk := .T., oDlg:End() )
@158,127 BUTTON aCtl[ 8 ] PROMPT "Salir" OF oDlg SIZE 40, 12 PIXEL ;
ACTION oDlg:End() CANCEL
oDlg:bGotFocus := { || aCtl[ 6 ]:SetFocus() }
ACTIVATE DIALOG oDlg CENTERED ON INIT aCtl[ 6 ]:SetFocus() ;
VALID ( oFont:End(), oDrCur:End(), .T. )
If ! lOk
aDbf := {}
EndIf
Return aDbf
//--------------------------------------------------------------------------------------------------------------------//
Static Function cGetFileName( lXls )
Default lXls := .T.
Return LongFileName( cGetFile32( If( lXls, "Libro Excel (*.xls) | *.xls", "Base de Datos (*.dbf) | *.dbf" ), ;
"Selecciona el Archivo",,, .F. ) )
//--------------------------------------------------------------------------------------------------------------------//
Static Function fDropDrag( nSourceRow, nTargetRow, nAt, oBrw )
Local aItem, nEle, nAnt, nSkip
If ! ( ValType( nSourceRow ) == "N" .and. ValType( nTargetRow ) == "N" .and. ;
nSourceRow >= 1 .and. nTargetRow >= 1 .and. nSourceRow <= Len( oBrw:aArray ) .and. ;
nTargetRow <= Len( oBrw:aArray ) )
Return Nil
EndIf
nSkip := nTargetRow - nSourceRow
If nSkip < 0
nEle := AScan( aRedir, {|e| e[ 1 ] == nAt } )
aRedir[ nEle, 2 ] := nAt + nSkip // nTargetRow
For nAnt := 1 To ( nAt - 1 )
aRedir[ nAnt, 2 ] ++
Next
Else
nEle := AScan( aRedir, {|e| e[ 1 ] == nAt } )
aRedir[ nEle, 2 ] := nTargetRow
For nAnt := Len( aRedir ) To ( nAt + 1 ) Step -1
aRedir[ nAnt, 2 ] --
Next
EndIf
aItem := AClone( oBrw:aArray[ nAt ] )
ADel( oBrw:aArray, nAt )
nAt += nSkip
AIns( oBrw:aArray, nAt )
oBrw:aArray[ nAt ] := AClone( aItem )
oBrw:Refresh()
oBrw:lHasChanged := .T.
Return Nil
//--------------------------------------------------------------------------------------------------------------------//
Function fTraMsg()
Return Nil
//--------------------------------------------------------------------------------------------------------------------//
Function fManMsg()
Return Nil
//--------------------------------------------------------------------------------------------------------------------//
Static Function LongFileName( cShName )
Local nLen, ;
cBuffer := Space( 255 ), ;
cFilNam := Space( 255 )
cShName := AllTrim( cShName )
nLen := GetFullName( cShName, 255, @cBuffer, @cFilNam )
Return UppCap( Left( cBuffer, nLen ) )
//--------------------------------------------------------------------------------------------------------------------//
DLL32 Static Function GetFullName( cFileName AS STRING, nBuffer AS LONG, @lpBuffer AS STRING, @lpFilePart AS STRING ) ;
AS LONG PASCAL FROM "GetFullPathNameA" LIB "kernel32.dll"
