syspel Posted April 18, 2017 Report Share Posted April 18, 2017 ola bom dia pessoal alguem tem uma funcao que le xls para dbf ou txt do excel para dbf obrigado carlos fhw 1404 xharbour 123 dbf xdev bcc 5.82 Quote Link to comment Share on other sites More sharing options...
kapiaba Posted April 18, 2017 Report Share Posted April 18, 2017 // Exemplos no FiveWin Brasil: http://fivewin.com.br/index.php?/topic/21090-excel-dbf-resolvido/ http://fivewin.com.br/index.php?/topic/21773-excel-ler-o-arquivo-e-transferir-para-um-dbf-resolvido/ // 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" Quote Link to comment Share on other sites More sharing options...
Jmsilva Posted April 18, 2017 Report Share Posted April 18, 2017 No proprio Excel tem a opcao de salvar como DBF. Quote Link to comment Share on other sites More sharing options...
Recommended Posts
Join the conversation
You can post now and register later. If you have an account, sign in now to post with your account.