Jump to content
Fivewin Brasil

xls para dbf

syspel

By syspel
in Programação

 Share

Recommended Posts

kapiaba Enthusiast

kapiaba

Posted
Posted

// 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"

Link to comment
Share on other sites

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

Guest
Reply to this topic...

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

Loading...
×
 Share
Go to topic listing
×
×
  • Create New...