5 de octubre de 2006

Exportar Cursor VFP a EXCEL

Hace un tiempo atrás encontré en este portal una rutina que me fue muy útil, pues exportaba tablas o cursores de VFP a un Libro Excel.

El inconveniente que se me presentó es que cuando utilizaba exportaciones de tablas con demasiados registros, la espera era eterna. Producto que la rutina en cuestión escribía celda a celda los datos de cada registro de la tabla.

Pues bien, buscando siempre mejorar los métodos, les presento esta rutina de exportación de tablas y/o cursores que se apoya en la importación de datos tipo texto de Microsoft Excel:

********************************************************************
********************************************************************
*!* FUNCTION Exp2Excel( [cCursor, [cFileSave, [cTitulo]]] )
*!*
*!* Exporta un Cursor de Visual FoxPro a Excel, utilizando la
*!* técnica de importación de datos externos en modo texto.
*!*
*!* PARAMETROS OPCIONALES:
*!* - cCursor  Alias del cursor que se va a exportar.
*!*            Si no se informa, utiliza el alias
*!*            en que se encuentra.
*!*
*!* - cFileName  Nombre del archivo que se va a grabar.
*!*              Si no se informa, muestra el libro generado
*!*              una vez concluída la exportación.
*!*
*!* - cTitulo  Titulo del informe. Si se informa, este
*!*            ocuparía la primera file de cada hoja del libro.
********************************************************************
********************************************************************
FUNCTION Exp2Excel( cCursor, cFileSave, cTitulo )
  LOCAL cWarning
  cWarning = "Exportar a EXCEL"
  IF EMPTY(cCursor)
    cCursor = ALIAS()
  ENDIF
  IF TYPE('cCursor') # 'C' OR !USED(cCursor)
    MESSAGEBOX("Parámetros Inválidos",16,cWarning)
    RETURN .F.
  ENDIF
  *********************************
  *** Creación del Objeto Excel ***
  *********************************
  WAIT WINDOW 'Abriendo aplicación Excel.' NOWAIT NOCLEAR
  oExcel = CREATEOBJECT("Excel.Application")
  WAIT CLEAR

  IF TYPE('oExcel') # 'O'
    MESSAGEBOX("No se puede procesar el archivo porque no tiene la aplicación" ;
      + CHR(13) + "Microsoft Excel instalada en su computador.",16,cWarning)
    RETURN .F.
  ENDIF

  oExcel.workbooks.ADD

  LOCAL lnRecno, lnPos, lnPag, lnCuantos, lnRowTit, lnRowPos, i, lnHojas, cDefault

  cDefault = ADDBS(SYS(5)  + SYS(2003))

  SELECT (cCursor)
  lnRecno = RECNO(cCursor)
  GO TOP

  *************************************************
  *** Verifica la cantidad de hojas necesarias  ***
  *** en el libro para la cantidad de datos     ***
  *************************************************
  lnHojas = ROUND(RECCOUNT(cCursor)/65000,0)
  DO WHILE oExcel.Sheets.COUNT < lnHojas
    oExcel.Sheets.ADD
  ENDDO

  lnPos = 0
  lnPag = 0

  DO WHILE lnPos < RECCOUNT(cCursor)

    lnPag = lnPag + 1 && Hoja que se está procesando

    WAIT WINDOWS 'Exportando cursor '  + UPPER(cCursor)  + ' a Microsoft Excel...' ;
      + CHR(13) + '(Hoja '  + ALLTRIM(STR(lnPag))  + ' de '  + ALLTRIM(STR(lnHojas)) ;
      + ')' NOCLEAR NOWAIT

    IF FILE(cDefault  + cCursor  + ".txt")
      DELETE FILE (cDefault  + cCursor  + ".txt")
    ENDIF

    COPY  NEXT 65000 TO (cDefault  + cCursor  + ".txt") DELIMITED WITH CHARACTER ";"
    lnPos = RECNO(cCursor)

    oExcel.Sheets(lnPag).SELECT

    XLSheet = oExcel.ActiveSheet
    XLSheet.NAME = cCursor + '_' + ALLTRIM(STR(lnPag))

    lnCuantos = AFIELDS(aCampos,cCursor)

    ********************************************************
    *** Coloca título del informe (si este es informado) ***
    ********************************************************
    IF !EMPTY(cTitulo)
      XLSheet.Cells(1,1).FONT.NAME = "Arial"
      XLSheet.Cells(1,1).FONT.SIZE = 12
      XLSheet.Cells(1,1).FONT.BOLD = .T.
      XLSheet.Cells(1,1).VALUE = cTitulo
      XLSheet.RANGE(XLSheet.Cells(1,1),XLSheet.Cells(1,lnCuantos)).MergeCells = .T.
      XLSheet.RANGE(XLSheet.Cells(1,1),XLSheet.Cells(1,lnCuantos)).Merge
      XLSheet.RANGE(XLSheet.Cells(1,1),XLSheet.Cells(1,lnCuantos)).HorizontalAlignment = 3
      lnRowPos = 3
    ELSE
      lnRowPos = 2
    ENDIF

    lnRowTit = lnRowPos - 1
    **********************************
    *** Coloca títulos de Columnas ***
    **********************************
    FOR i = 1 TO lnCuantos
      lcName  = aCampos(i,1)
      lcCampo = ALLTRIM(cCursor) + '.' + aCampos(i,1)
      XLSheet.Cells(lnRowTit,i).VALUE=lcname
      XLSheet.Cells(lnRowTit,i).FONT.bold = .T.
      XLSheet.Cells(lnRowTit,i).Interior.ColorIndex = 15
      XLSheet.Cells(lnRowTit,i).Interior.PATTERN = 1
      XLSheet.RANGE(XLSheet.Cells(lnRowTit,i),XLSheet.Cells(lnRowTit,i)).BorderAround(7)
    NEXT

    XLSheet.RANGE(XLSheet.Cells(lnRowTit,1),XLSheet.Cells(lnRowTit,lnCuantos)).HorizontalAlignment = 3

    *************************
    *** Cuerpo de la hoja ***
    *************************
    oConnection = XLSheet.QueryTables.ADD("TEXT;"  + cDefault  + cCursor  + ".txt", ;
      XLSheet.RANGE("A"  + ALLTRIM(STR(lnRowPos))))

    WITH oConnection
      .NAME = cCursor
      .FieldNames = .T.
      .RowNumbers = .F.
      .FillAdjacentFormulas = .F.
      .PreserveFormatting = .T.
      .RefreshOnFileOpen = .F.
      .RefreshStyle = 1 && xlInsertDeleteCells
      .SavePassword = .F.
      .SaveData = .T.
      .AdjustColumnWidth = .T.
      .RefreshPeriod = 0
      .TextFilePromptOnRefresh = .F.
      .TextFilePlatform = 850
      .TextFileStartRow = 1
      .TextFileParseType = 1 && xlDelimited
      .TextFileTextQualifier = 1 && xlTextQualifierDoubleQuote
      .TextFileConsecutiveDelimiter = .F.
      .TextFileTabDelimiter = .F.
      .TextFileSemicolonDelimiter = .T.
      .TextFileCommaDelimiter = .F.
      .TextFileSpaceDelimiter = .F.
      .TextFileTrailingMinusNumbers = .T.
      .REFRESH
    ENDWITH

    XLSheet.RANGE(XLSheet.Cells(lnRowTit,1),XLSheet.Cells(XLSheet.ROWS.COUNT,lnCuantos)).FONT.NAME = "Arial"
    XLSheet.RANGE(XLSheet.Cells(lnRowTit,1),XLSheet.Cells(XLSheet.ROWS.COUNT,lnCuantos)).FONT.SIZE = 8

    XLSheet.COLUMNS.AUTOFIT
    XLSheet.Cells(lnRowPos,1).SELECT
    oExcel.ActiveWindow.FreezePanes = .T.

    WAIT CLEAR

  ENDDO

  oExcel.Sheets(1).SELECT
  oExcel.Cells(lnRowPos,1).SELECT

  IF !EMPTY(cFileSave)
    oExcel.DisplayAlerts = .F.
    oExcel.ActiveWorkbook.SAVEAS(cFileSave)
    oExcel.QUIT
  ELSE
    oExcel.VISIBLE = .T.
  ENDIF

  GO lnRecno

  RELEASE oExcel,XLSheet,oConnection

  IF FILE(cDefault + cCursor + ".txt")
    DELETE FILE (cDefault + cCursor + ".txt")
  ENDIF

  RETURN .T.

ENDFUNC

***
***
Saludos desde Chile,

OSCAR CALDERON FUENTES

14 comentarios :

  1. Buen dìa
    Oscar Calderón Fuentes

    Muy buen trabaja muy limpio y fácil de entender y de utilizar Felicidades.

    Me preguntaba si te interesa apoyarme algunos proyectos de programación en VFP ? Tu me informas por medio Skype se me facilita, No podríamos de acuerdo lo que necesito y tu me indicas tiempo y costos ?

    Saludos Cordiales.
    Raúl Orea Tirado.

    Nota: Para utilizar este código que costo tiene o donación a donde lo podría hacer para continua esta aportando a esta comunidad.
    me contactas raul.orea.t@gmail.com o siconeterp@gmail.com

    ResponderBorrar
  2. He utilizado esta rutina, pero si tengo datos con la letra 'Ñ' solo sale un simbolo en su reemplazo. ¿como hago para evitar esto?

    ResponderBorrar
  3. Gracias por el aporte pero no sé cómo utilizarlo.
    Copié el código fuente en un archivo .prg lo llamo con DO NombreProgama|NombreProcedimiento [IN NombrePrograma WITH ListaParametro pero no creó el archivo de exportación a MSO Excel es un error o hay un truco.
    Me gustaría saber cómo exportar directamente los Reportes (REPORT FORM ("Reports\NombreArchivo") TO PRINTER PROMPT SUMMARY
    o REPORT FORM ("Reports\NombreArchivo") PREVIEW
    ) creados en VFP9 a cualquier formatos ("HTML, XML, SHTML, XHTML, DHTML, XSD, XSLT, PDF, XLSX, DOCX" etc.) funcional y explicado de cómo usarlo detalladamente pero sin tantas palabras de adornos (directo, preciso, conciso, locuaz, etc.). Gracias.

    ResponderBorrar
  4. Muchas Gracias es genial!!
    Solo que por cosas de la vida un cursor me dio 91.601 registros y al dividir entre 65.000 solo creo una hoja, pero lo solucione reemplazando esta linea...:
    *************************************************
    *** Verifica la cantidad de hojas necesarias ***
    *** en el libro para la cantidad de datos ***
    *************************************************
    lnHojas = ROUND(RECCOUNT(cCursor)/65000,0)



    *!*.....POR ESTAS ;
    *************************************************
    *** Verifica la cantidad de hojas necesarias ***
    *** en el libro para la cantidad de datos ***
    *************************************************
    lnHojas = (RECCOUNT(cCursor)/65000)
    nDecimal = lnHojas - INT(lnHojas)
    IF nDecimal > 0.0
    lnHojas = INT(lnHojas + 1)
    ENDIF

    ResponderBorrar
  5. Buenos días,estuve observando el código y es perfecto para lo que necesito pero me he dado cuenta que el formato numérico me sale con mas ceros de los que realmente trae el número, por ejemplo en el cursor
    viene 330,500.00 y en el excel este se transforma en 3.305.000.000 me podrías colaborar dándome un guía de como solucionar esto, te lo agradecería mucho, gracias

    ResponderBorrar
    Respuestas
    1. hola me tope con esto ... lo pudiste resolver ???

      Borrar
    2. Yo lo solucioné haciendo un ajuste en la sección de titulo de columnas:

      **********************************
      *** Coloca títulos de Columnas ***
      **********************************
      nAsc = ASC('A')
      nAsc2 = nAsc
      cColBase = ''
      FOR i = 1 TO lnCuantos
      lcName = aCampos(i,1)
      lcCampo = ALLTRIM(cCursor) + '.' + aCampos(i,1)
      XLSheet.Cells(lnRowTit,i).VALUE=lcname
      XLSheet.Cells(lnRowTit,i).FONT.bold = .T.
      XLSheet.Cells(lnRowTit,i).Interior.ColorIndex = 15
      XLSheet.Cells(lnRowTit,i).Interior.PATTERN = 1
      XLSheet.RANGE(XLSheet.Cells(lnRowTit,i),XLSheet.Cells(lnRowTit,i)).BorderAround(7)

      cCol = cColBase + CHR(nAsc)
      DO case
      CASE aCampos(i,2) = 'C'
      oExcel.Columns(cCol+':'+cCol).Select
      oExcel.Selection.NumberFormat = "@"
      CASE aCampos(i,2) = 'D'
      oExcel.Columns(cCol+':'+cCol).Select
      oExcel.Selection.NumberFormat = "dd/mmm/yy"
      CASE aCampos(i,2) = 'N' AND aCampos(i,4) = 2
      oExcel.Columns(cCol+':'+cCol).Select
      oExcel.Selection.NumberFormat = "#,##0.00"
      *CASE aCampos(nI,2) = 'N'
      *oExcel.Columns(cCol+':'+cCol).Select
      * oExcel.Selection.NumberFormat = "#,##0"
      ENDCASE
      * oExcel.Cells(1,nI).Font.Bold = .t.
      * oExcel.Cells(1,nI).FormulaR1C1 = aCampos(nI,1)


      nAsc = nAsc + 1
      IF CHR(nAsc - 1) = 'Z'
      cColBase = CHR(nAsc2)
      nAsc = ASC('A')
      nAsc2 = nAsc2 + 1
      ENDIF

      NEXT

      XLSheet.RANGE(XLSheet.Cells(lnRowTit,1),XLSheet.Cells(lnRowTit,lnCuantos)).HorizontalAlignment = 3

      Borrar
    3. Efectivamente el traspaso se hace muy rápido. Pero, tanto con este código como con el anterior, lo datos numéricos son traspasados como tipo texto, por lo que no se puede operar con ellos. En realidad creo que que es tan rápido porque los datos no se transfieren celda a celda, sino un fichero texto (.txt) que luego es borrado, pero en ese traspaso lo datos los de tipo numérico se pasan como texto. Esto impide cualquier operación numérica con ellos. Es una lástima porque es muy rápido. A ver si puedes averiguar dónde está la solución.

      Borrar
  6. Buenas tardes.

    tengo el siguiente codigo para enviar mis registros de una tabla .dbf a excel:
    *!* GENERACION A MICROSOFT EXCEL
    **--------------------------------------------**
    LError = ON('error')
    ON ERROR xlapp = NULL
    xlapp = GETOBJECT('Excel Application')
    ON ERROR &LError
    IF ISNULL(xlapp)
    xlapp = CREATEOBJECT('Excel.Application')
    ENDIF
    WITH xlapp
    .VISIBLE = 'True'
    .DisplayAlerts = 'False'
    .Workbooks.ADD()
    ENDWITH

    xlsheet = xlapp.ActiveSheet
    WITH xlsheet
    .COLUMNS("A:A").ColumnWidth = 15.00
    .COLUMNS("B:B").ColumnWidth = 18.00
    .COLUMNS("C:C").ColumnWidth = 18.00
    .COLUMNS("D:D").ColumnWidth = 18.00
    .COLUMNS("E:E").ColumnWidth = 18.00
    .COLUMNS("F:F").ColumnWidth = 37.00
    .COLUMNS("G:G").ColumnWidth = 12.00
    .COLUMNS("H:H").ColumnWidth = 15.00
    .COLUMNS("I:I").ColumnWidth = 22.00
    ENDWITH

    Estoy utilizando Excel 2013. pero en una PC que tiene Office 365 me marca el siguiente error:

    Class definition EXCEL.APPLICATION is not found.

    Alguien sabe cómo usar este tipo de exportacion pero con office 365 ???

    Gracias!

    ResponderBorrar
  7. Estimado!, excelente el código! Muchas gracias!

    Tengo una consulta, como puedo hacer para que en la exportación, las celdas que en el cursor son TEXTO (ej: "004433") me respete el formato de origen?, porque en la salida me las toma como "4433".

    MUCHAS GRACIAS!

    ResponderBorrar
  8. En la hoja resultante los campos numéricos dan errores de !VALOR al intentar operar con ellos.

    ResponderBorrar
  9. Efectivamente el código es muy rápido, aunque en la hoja Excel resultante los campos numéricos son pasados como texto, no como números, por lo que no permiten operar con ellos. Pienso que la rapidez es debida a que los datos no se traspasan celda a celda, sino que se crea un archivo de texto (txt) para ser traspasado, este archivo luego es borrado. El inconveniente está en que los datos numéricos los traspasa también como texto.

    ResponderBorrar

Los comentarios son moderados, por lo que pueden demorar varias horas para su publicación.