Re: Como convierto un DBF a Excel
Posted: Thu Mar 14, 2013 9:34 pm
Si ve alguien si ven mi rutina???
Gracias
Polo
Gracias
Polo
Exclusive forum for HMG, a Free / Open Source xBase WIN32/64 Bits / GUI Development System
http://www.hmgforum.com/
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 wrote:No sube el archivo...
Otro dia será.
sen de mi brütüs ?mol wrote:Dzięki chłopaki, wszystko zrozumiałem od ręki