Como convierto un DBF a Excel

HMG en Español

Moderator: Rathinagiri

Leopoldo Blancas
Posts: 344
Joined: Wed Nov 21, 2012 7:14 pm
Location: México
Has thanked: 1 time
Been thanked: 4 times

Re: Como convierto un DBF a Excel

Post by Leopoldo Blancas » Thu Mar 14, 2013 9:34 pm

Si ve alguien si ven mi rutina???

Gracias
Polo

Leopoldo Blancas
Posts: 344
Joined: Wed Nov 21, 2012 7:14 pm
Location: México
Has thanked: 1 time
Been thanked: 4 times

Post by Leopoldo Blancas » Thu Mar 14, 2013 9:40 pm

No encuentro....

Code: Select all

/*
 * HMG ReadXLS Demo
 * Contributed by Isma Elias <farfa890@gmail.Com> y Leopoldo Blancas jijiji
 */

#include "MiniGUI.ch"
#include "Dbstruct.ch"

#define NTrim( n ) LTRIM( STR( n, IF( n == INT( n ), 0, 2 ) ) )
#define TRUE      .T.
#define FALSE     .F.

Static aNamis   := {}
Static aFila    := {}
Static aWitis   := {}
Static aHojita  := {}

Static nWcrt    := 0
Static nHcrt    := 0

Function Main()
   PRIVATE cArchivo := ''
   PRIVATE aTypeCol:={}
   PRIVATE nFilas   := 0
   PRIVATE nnColumn := 0
   
   PRIVATE aStruct
   PRIVATE nTotalReg

   nWcrt    := GetDesktopWidth()
   nHcrt    := GetDesktopHeight()-28

    DEFINE WINDOW WinMain ;
        AT 0,0 WIDTH nWcrt HEIGHT nHcrt ;
        TITLE 'LEER UN EXCEL o un DBF a EXCEL!!!! ' ;
        MAIN

        @050,001 GRID Grid_1 WIDTH nWcrt-03 HEIGHT nHcrt-100 ;
                 FONT "Ms Sans Serif" SIZE 09 ;
                 HEADERS { "" }    ;
                 WIDTHS { 100 }   ;
                 ITEMS  { { "" } };
                 VALUE  1

        DEFINE BUTTON cmdxls
            ROW 015
            COL 005
            WIDTH  98
            HEIGHT 24
            CAPTION "&Abrir XLS"
            FONTNAME "Ms Sans Serif"
            FONTSIZE 9
            ACTION FAR_OpenXLS()
            FLAT .T.
        END BUTTON

        
        DEFINE LABEL Label_1
            ROW 018
            COL 105
            WIDTH  190
            HEIGHT 24
            VALUE "Nombre del Archivo *.DBF :"
            FONTNAME "Ms Sans Serif"
            FONTSIZE 9
            FONTBOLD .T.
        END LABEL       
        
        DEFINE TEXTBOX TextBox_1
            ROW 015
            COL 265
            WIDTH  98
            HEIGHT 24
            FONTNAME "Ms Sans Serif"
            FONTSIZE 9
        END TEXTBOX        
        
        
        DEFINE BUTTON Boton_2
            ROW 015
            COL 365
            WIDTH  98
            HEIGHT 24
            CAPTION "Grabar a DBF"
            FONTNAME "Ms Sans Serif"
            FONTSIZE 9
            ACTION GrabaDBF()
            FLAT .T.
        END BUTTON

        DEFINE LABEL Label_2
            ROW 015
            COL nWcrt-150
            WIDTH  190
            HEIGHT 24
            VALUE ""
            FONTNAME "Ms Sans Serif"
            FONTSIZE 14
            FONTBOLD .T.
        END LABEL               

        
        DEFINE BUTTON Boton_3
            ROW 015
            COL 545
            WIDTH  120
            HEIGHT 24
            CAPTION "Abrir DBF a Excel"
            FONTNAME "Ms Sans Serif"
            FONTSIZE 9
            ACTION FAR_OpenDBF()
            FLAT .T.
        END BUTTON

        DEFINE LABEL Label_3
            ROW 015
            COL nWcrt-350
            WIDTH  190
            HEIGHT 25
            VALUE "Total de Registros:"
            FONTNAME "Ms Sans Serif"
            FONTSIZE 14
            FONTBOLD .T.
        END LABEL               
        
    END WINDOW

    WinMain.Maximize()

    ACTIVATE WINDOW WinMain

Return Nil
*--------------------------------------------------------------------------------------------------------------------------------------------------


Static Function FAR_OpenXLS()

     LOCAL ccFile

     if EMPTY(ccFile) .or. ccFile==NIL .or. LEN(ccFile)=0 .or. !file(ccFile)
        ccFile := getfile({{"Archivos excel  (*.xls)","*.xls"}},"Seleccione un archivo excel",GetCurrentFolder(),.f.)
     endif

     if EMPTY(ccFile) .or. ccFile==NIL .or. LEN(ccFile)=0 .or. !file(ccFile)
        return nil
     endif
     
     cArchivo := SUBSTR(ccFile,RAT("\",ccFile)+1) 
     cArchivo := SUBSTR(cArchivo,1,RAT(".",cArchivo)-1) 
     WinMain.TextBox_1.VALUE := cArchivo
*     MsgBox(cArchivo)
     Load_XLS_CLI( ccFile )
     WinMain.TextBox_1.VALUE := ccFile

Return Nil

*--------------------------------------------------------------------------------------------------------------------------------------------------------
Static Function Load_XLS_CLI( cArchivo )

*     LOCAL nFilas   := 0
     LOCAL nColumns := 0
*     LOCAL nnColumn := 0
     LOCAL nuColumn
     LOCAL ccValue
     LOCAL i        := 0
     LOCAL j        := 0

     LOCAL oExcel   as Object
     LOCAL oWorkBook
     LOCAL oHoja
     LOCAL ccNameIs := ""

     LOCAL NoSale  := TRUE
     LOCAL nnWiti  := 0
     LOCAL aTypes  AS ARRAY


     
     oExcel := TOleAuto():New( "Excel.Application" )
     IF  oExcel == nil
          MsgStop('Excel no está instalado!','Error')
          RETURN Nil
     Endif

     oWorkBook := oExcel:WorkBooks:Open( cArchivo )

     oExcel:Sheets(1):Select()
     oHoja := oExcel:ActiveSheet()
     oExcel:Visible       := .F.     // <---- No Mostrar
     oExcel:DisplayAlerts := .F.     // <---- esta elimina mensajes
     //
     ************** LOOP LECTURA PLANILLA EXCEL ******************
     //
     //------------ Averiguo Cantida de Filas    ------------------
     //
     nFilas    := oHoja:UsedRange:Rows:Count()
     WinMain.Label_2.VALUE := TRANSFORM(nFilas, "999,999,999")
     //
     //------------ Averiguo Cantida de Columnas ------------------
     //
     nnColumn := 0
     //
     aNamis  := {}
     //
     i := 0
     nuColumn := 0

     nColumns := Len( getProperty( "WinMain", "Grid_1", "Item", 1 ) )

     DO WHILE nColumns != 0
         WinMain.Grid_1.DeleteColumn( nColumns )
         nColumns--
     ENDDO

     Do While NoSale

        i := i + 1

        ccValue := AnyToString( oHoja:cells(2,i):value )
        nnWiti := GetLenColumn( LEN( ccValue )  )

        ccNameIs := AnyToString( oHoja:cells(01, i):value )
        IF EMPTY( ccNameIs ) .or. LEN( ccNameIs ) = 0 .or. ccNameIs = ' '

           nuColumn := i - 1
           NoSale := FALSE

        ELSE

           WinMain.Grid_1.AddColumn( i, ccNameIs, nnWiti, 0 )
           Do Events

           AADD(aNamis, ccNameIs )
           AADD(aWitis, 120)
           nnColumn := i
        ENDIF

     EndDo
     //
     IF  nuColumn <> nnColumn

         MsgInfo("nuColumn " + str(nuColumn) +  " nnColumn " + str(nnColumn))
     ENDIF
     //
     //------------------------------------------------------------

     FOR i:=1 TO nnColumn Step 1
      TipoDeDatos(oHoja:cells(2,i):value)
*      Msgbox(STR(i))
     NEXT i

	 WAIT WINDOW "Processing..."  NOWAIT
     //
     aFila  := {}
     aTypes := {}
     //
     FOR i=2 TO nFilas Step 1

          FOR j=1 TO nnColumn Step 1

             ccValue := AnyToString( oHoja:cells(i,j):value )
             AADD(aFila, ccValue )
             AADD(aTypes, "C")

          NEXT j

          WinMain.Grid_1.addItem( ItemChar(aFila, aTypes) )

          AADD(aHojita, aFila )
          aFila  := {}
          aTypes := {}
          Do Events

     Next i
	 
	 WAIT CLEAR

     oExcel:DisplayAlerts := .F. // <---- esta elimina mensajes
     oWorkBook:Close()
     oExcel:Quit()

     oWorkBook := NIL
     oHoja := NIL
     oExcel := NIL

     WinMain.title := cArchivo
     Release oWorkBook
     Release oHoja
     Release oExcel

RETURN Nil

*----------------------------------------------------------------------*
FUNCTION ItemChar(aLine, aType)
*----------------------------------------------------------------------*

    LOCAL aRet:={}, x:=0, l:=0
    aRet:=array( len(aLine) )
    l:=len(aRet)
    
    FOR x:=1 TO l
        do case
        case aType[x]=="N"
             aRet[x]:=NTrim(aLine[x])
        case aType[x]=="D"
             aRet[x]:=dtoc(aLine[x])
        case aType[x]=="L"
             aRet[x]:=iif(aLine[x], "TRUE", "FALSE")
        otherwise
             aRet[x]:=aLine[x]
        endcase
    NEXT

RETURN aRet


FUNCTION AnyToString(csValue)

   LOCAL ccValor := ""
   LOCAL cdate
   LOCAL cFormatoDaData := set(4)

   SET DECIMALS   TO 0

   DO CASE
   CASE Valtype(csValue) == "N"
        ccValor := AllTrim(Str(csValue))
   CASE Valtype(csValue) == "D"
        IF !Empty(csValue)
           cdate := dtos(csValue)
           ccValor := substr(cDate,1,4) + "-" + substr(cDate,5,2) + "-" + substr(cDate,7,2)
        ELSE
           ccValor := ""
        ENDIF
   CASE Valtype(csValue) == "T"
        IF !Empty(csValue)
           cdate := dtos(csValue)
           ccValor := substr(cDate,1,4) + "-" + substr(cDate,5,2) + "-" + substr(cDate,7,2)
        ELSE
           ccValor := ""
        ENDIF
   CASE Valtype(csValue) $ "CM"
        IF Empty( csValue)
           ccValor=""
        ELSE
           ccValor := "" + csValue+ ""
        ENDIF
   CASE Valtype(csValue) == "L"
        ccValor := AllTrim(Str(iif(csValue == .F., 0, 1)))
   OTHERWISE
        ccValor := ""       // NOTE: Here we lose csValues we cannot convert

   ENDCASE

RETURN( ccValor )


FUNCTION GetLenColumn( nnLen )

    LOCAL nnValor := 120
    IF nnLen < 6
       nnValor := 70
    ELSEIF nnLen < 10
       nnValor := 110
    ELSEIF nnLen < 20
       nnValor := 140
    ELSEIF nnLen < 40
       nnValor := 240
    ELSE
       nnValor := 380
    ENDIF

RETURN( nnValor )
*-----------------------------------------------------------------------------------------------------------------------------------------------------------

PROCEDURE TipoDeDatos(csValue)

   DO CASE
   CASE Valtype(csValue) == "N"
             AADD(aTypeCol,"N")
   CASE Valtype(csValue) == "D"
             AADD(aTypeCol,"D")
   CASE Valtype(csValue) == "T"
             AADD(aTypeCol,"D")
   CASE Valtype(csValue) $ "CM"
             AADD(aTypeCol,"C")
   CASE Valtype(csValue) == "L"
             AADD(aTypeCol,"L")
   OTHERWISE
             AADD(aTypeCol,"C")
   ENDCASE

RETURN nil


*-----------------------------------------------------------------------------------------------------------------------------------------------------------
PROCEDURE GrabaDBF()
LOCAL cCampo     := ''
LOCAL nAnchoMax   := 0
LOCAL cColumna    := ''
LOCAL cCreate    := '' 
PRIVATE aAnchosCampos := {}
PRIVATE aEncabezados  := {}

      cArchivo := ALLTRIM(WinMain.TextBox_1.VALUE)

      FOR i=1 TO nnColumn Step 1
         nAnchoMax := 0
         FOR j=2 TO nFilas Step 1
            IIF(nAnchoMax < LEN(WinMain.Grid_1.Cell(j,i)),nAnchoMax := LEN(WinMain.Grid_1.Cell(j,i)), )
         NEXT j
         Do Events
         AADD(aAnchosCampos, nAnchoMax )
      Next i

      FOR i=1 TO nnColumn Step 1
         cColumna:= WinMain.Grid_1.Header(i)
         AADD(aEncabezados, cColumna)
      Next i
      
      cCreate := "{"
      
      FOR i:=1 TO nnColumn Step 1
         IF i == nnColumn
            cCreate := cCreate + "{ '"+ aEncabezados[i] +"' , '"+ aTypeCol[i] +"', "+ ALLTRIM(STR(aAnchosCampos[i]))+",0}"
         ELSE
            cCreate := cCreate + "{ '"+ aEncabezados[i] +"' , '"+ aTypeCol[i] +"', "+ ALLTRIM(STR(aAnchosCampos[i]))+",0},"
         ENDIF
      NEXT i
      cCreate := cCreate + "}"

    IF !File(cArchivo)      
		MsgBox('No Existe el *.DBF')
		DBCREATE(cArchivo, &(cCreate) )
			   
		USE &(cArchivo) ALIAS &(cArchivo) NEW

		FOR i:=1 To nFilas Step 1
				APPEND BLANK
			FOR j:=1 TO nnColumn Step 1
			cCampo := aEncabezados[j]
			&(cArchivo)->&(cCampo) := WinMain.Grid_1.Cell(i,j)
			NEXT j
		NEXT i
		Do Events
	ELSE
		  
		USE &(cArchivo) ALIAS &(cArchivo) NEW

		FOR i:=1 To nFilas Step 1
				APPEND BLANK
			FOR j:=1 TO nnColumn Step 1
			cCampo := aEncabezados[j]
			&(cArchivo)->&(cCampo) := WinMain.Grid_1.Cell(i,j)
			NEXT j
		NEXT i
		Do Events
    ENDIF
      
      DBCLOSEALL()


RETURN NIL

*-----------------------------------------------------------------------------------------------------------------------------------------------------------
PROCEDURE FAR_OpenDBF()
     LOCAL ccFile, nCampos, aCampos:={}

     if EMPTY(ccFile) .or. ccFile==NIL .or. LEN(ccFile)=0 .or. !file(ccFile)
        ccFile := getfile({{"Archivos excel  (*.DBF)","*.dbf"}},"Seleccione un archivo DBF",GetCurrentFolder(),.f.)
     endif

     if EMPTY(ccFile) .or. ccFile==NIL .or. LEN(ccFile)=0 .or. !file(ccFile)
        return nil
     endif
     
     cArchivo := SUBSTR(ccFile,RAT("\",ccFile)+1) 
     cArchivo := SUBSTR(cArchivo,1,RAT(".",cArchivo)-1) 
     WinMain.TextBox_1.VALUE := cArchivo
	
	USE &(cArchivo) ALIAS &(cArchivo) NEW
	
	aStruct := &(cArchivo)->(DBSTRUCT())
	

	nTotalReg := &(cArchivo)->(LASTREC())
	WinMain.Label_2.VALUE := TRANSFORM(nTotalReg , "999,999,999")
	&(cArchivo)->(DBGOTOP())

	Excel()
	
RETURN NIL
*-----------------------------------------------------------------------------------------------------------------------------------------------------------
STATIC PROCEDURE Excel()
LOCAL oExcel, oHoja, cCampo, i

   oExcel := CreateObject( "Excel.Application" )

   oExcel:WorkBooks:Add()

   oHoja := oExcel:ActiveSheet()

   oHoja:Cells:Font:Name := "Arial"
   oHoja:Cells:Font:Size := 12



    FOR n:=1 TO LEN(aStruct) STEP 1
		cCampo := aStruct[n][1]
		oHoja:Cells( 1,n ):Value := cCampo
    NEXT n
	
	&(cArchivo)->(DBGOTOP())

	WAIT WINDOW "Processing..."  NOWAIT

	i:=2
	DO WHILE !EOF()
	    FOR n:=1 TO LEN(aStruct) STEP 1
			cCampo := aStruct[n][1]
			oHoja:Cells( i,n ):Value := &(cArchivo)->&(cCampo)
		NEXT n
		&(cArchivo)->(DBSKIP())
		i:=i+1
	END DO
	Do Events
	
	WAIT CLEAR

    FOR n:=1 TO LEN(aStruct) STEP 1
		oHoja:Columns( n ):AutoFit()
    NEXT n

   oHoja:Cells( 1, 1 ):Select()

   oExcel:Visible := .T.


RETURN

Leopoldo Blancas
Posts: 344
Joined: Wed Nov 21, 2012 7:14 pm
Location: México
Has thanked: 1 time
Been thanked: 4 times

Post by Leopoldo Blancas » Thu Mar 14, 2013 9:43 pm

Witaj Mol ... Gdybym był w sklepie .... :lol: :lol: :lol:

Saludos
Polo

User avatar
CarlosRD
Posts: 63
Joined: Thu Jan 31, 2013 9:20 pm
Location: Orizaba, México
Been thanked: 1 time

Post by CarlosRD » Thu Mar 14, 2013 10:03 pm

hola a todos:

gustavo, arturo:

me da mucho gusto que la rutina les haya sido de utilidad.

polo, se ve interesante el ejemplo que agregaste, voy a probarlo.

para subir un archivo, sigue estos pasos:

empaca el archivo que deseas subir.
elije el archivo (esta opcion viene abajo del cuerpo de donde escribimos)
agrega el archivo (otro poquito mas abajo)
envia el post y listo.

saludos a todos.
Todo en el Nombre de Jesus / All in the name of Jesus
Carlos RD

Leopoldo Blancas
Posts: 344
Joined: Wed Nov 21, 2012 7:14 pm
Location: México
Has thanked: 1 time
Been thanked: 4 times

Post by Leopoldo Blancas » Thu Mar 14, 2013 10:14 pm

Si Carlos... pero no se por que pero no lo hace...
Saludos
Polo

Leopoldo Blancas
Posts: 344
Joined: Wed Nov 21, 2012 7:14 pm
Location: México
Has thanked: 1 time
Been thanked: 4 times

Post by Leopoldo Blancas » Thu Mar 14, 2013 10:17 pm

hola...

Leopoldo Blancas
Posts: 344
Joined: Wed Nov 21, 2012 7:14 pm
Location: México
Has thanked: 1 time
Been thanked: 4 times

Post by Leopoldo Blancas » Thu Mar 14, 2013 10:17 pm

No sube el archivo...
Otro dia será.

User avatar
danielmaximiliano
Posts: 2081
Joined: Fri Apr 09, 2010 4:53 pm
Location: Argentina
Has thanked: 114 times
Been thanked: 15 times
Contact:

Post by danielmaximiliano » Thu Mar 14, 2013 11:00 pm

Leopoldo Blancas wrote:No sube el archivo...
Otro dia será.


Polo :
comprime los archivos, utiliza el boton examina, agrega el archivo mediante "Add the file", si quieres pegar en archivo en algun lugar del texto que estas escribiendo solo utiliza el boton "place inline"
HMGforum.png
HMGforum.png (36.37 KiB) Viewed 794 times
*´¨)
¸.·´¸.·*´¨) ¸.·*¨)
(¸.·´. (¸.·` *
.·`.HMG : It's magic !
(¸.·``··*

Saludos / Regards
DaNiElMaXiMiLiAnO

Whatsapp. : +54901169026142
Telegram Name : DaNiElMaXiMiLiAnO

Leopoldo Blancas
Posts: 344
Joined: Wed Nov 21, 2012 7:14 pm
Location: México
Has thanked: 1 time
Been thanked: 4 times

Post by Leopoldo Blancas » Thu Mar 14, 2013 11:59 pm

Otra vez... :lol: :lol: :lol:

Leer_xls_dbf.rar
(3.47 KiB) Downloaded 145 times
OK... creo que el error era que no lo comprimia...

Gracias Daniel...

User avatar
esgici
Posts: 4458
Joined: Wed Jul 30, 2008 9:17 pm
DBs Used: DBF
Location: iskenderun / Turkiye
Has thanked: 336 times
Been thanked: 103 times
Contact:

Post by esgici » Fri Mar 15, 2013 4:18 am

mol wrote:Dzięki chłopaki, wszystko zrozumiałem od ręki :lol: :lol: :lol:
sen de mi brütüs ?
Viva INTERNATIONAL HMG :D

Post Reply