Clipper On Line • Ver Tópico - nfXML - Gera arquivos XML

nfXML - Gera arquivos XML

Aqui você poderá oferecer suas Contribuições, Dicas e Tutoriais (Texto ou Vídeo) que sejam de interesse de todos.

Moderador: Moderadores

 

nfXML - Gera arquivos XML

Mensagempor rochinha » 06 Dez 2005 00:09

/* 
*
* Arquivo...: TB2Xml.prg
* Autor.....: Jose Carlos da Rocha
* Adaptacao.: adaptado de TB2HTML.prg
* Versao....: 1.0, 05/Ago/2003
* Objetivo..: Adaptacao de NFHTML.PRG para geracao de arquivos XML
*
*/

/*  $DOC$
*  $FUNCNAME$
*     TB2XML()
*
*  $ONELINER$
*     Generates HTML tables (documents) from TBrowse objects
*
*  $SYNTAX$
*     TB2XML( <oTBrowse>, <cHtmlFile>, [<cTitle>] ) -> lSuccess
*
*  $ARGUMENTS$
*     <oTbrowse>   is a TBrowse object
*     <cHtmlFile>  is name of HTML (.HTM) document to generate
*     <cTitle>     is optional table title
*
*  $RETURNS$
*     Returns true (.T.) if successfull, false (.F.) in case of error.
*
*  $DESCRIPTION$
*     TB2XML() generates HTML tables based on TBrowse objects which
*     is passed as argument (along with target HTML file name and
*     optional title). It respects custom skip blocks, so it can be
*     used for converting arrays as well as standard DBF files.
*     TB2XML evaluates field data the same way TBrowse do
*     (evaluating the field code block) so works with calculated
*     columns without any problems. It also respects any additional
*     column formatting (TBColumn:picture) and replace empty values
*     with non-breaking spaces. Table header is automatically
*     generated from TBColumn:Heading with support for multi-line
*     headers.
*
*  $EXAMPLES$
*
*  // this is sample part of standard main TBrowse loop
*  do while .t.
*      oTB:forceStable()
*      nKey := Inkey()
*      do case
*      // standard key (up,down,etc.) processing goes here
*      case nKey == K_ALT_H
*          if Alert("Generate HTML table?", {"Yes","No"})==1
*
*              TB2XML (oTB, "Table.htm", "Sample table")
*
*          endif
*     end case
*  end do
*
*  $END$
*/

#include "FileIO.ch"

#define     CR          Chr(13)
#define     LF          Chr(10)
#define     CRLF        CR+LF

#xtranslate FWriteLn (<xHandle>, <cString>) => ;
            FWrite (<xHandle>, <cString> + CRLF)

/*
    Here are the static variables that keeps basic configuration -
    font colors and background image. If you have your set of prefered
    colors you may change this variables here, or (maybe better) add
    another function e.g. SetTB2XML (<bgColor>, <textColor>, <bgImage>)
    to change them. Color codes are in standard RGB form.
*/

static cSetClrBg    := "#ffffff"    // background color
static cSetClrTab   := "#ffff80"    // table background
static cSetClrText  := "#0000ff"    // text color (for table and header text)
static cSetBgImage  := "fundo3.gif" // background image (.GIF picture)

/*
    sample colors:
    fffffc0 - light yellow
    fffff80 - darker yellow
    00000ff - ligth blue
    fffffff - white
    0000000 - black
*/

**** ---------------------------------------- ****
function TB2XML (oTB, cHtmlFile, cTitle)

    local xHtml, xXml, i, oCol, nTemp
    local uColData, cAlign, cCell

    // argument checking
    if ValType(oTB) != "O"
        return .f.
    endif
    if Empty(cHtmlFile)
       cHtmlFile := "TB2XML.htm"
       cXmlFile  := "TB2XML.xml"
    endif
    cXmlFile  := substr(cHtmlFile,1,at('.',cHtmlFile)-1)+".xml"

    // creating new Xml (.HTM) file
    xHtml := FCreate (cHtmlFile, FC_NORMAL)
    if FError() != 0
        return .f.
    endif
    xXml  := FCreate (cXmlFile, FC_NORMAL)
    if FError() != 0
        return .f.
    endif

    // Xml header
    FWrite (xHtml, '<HTML>' + CRLF)
    FWrite (xHtml, '<HEAD>' + CRLF)
    FWrite (xHtml, '  <TITLE>' + cTitle + '</TITLE>' + CRLF)
    FWrite (xHtml, '  <meta name="Author" CONTENT="SoftClever">' + CRLF)
    FWrite (xHtml, '  <meta name="GENERATOR" CONTENT="' + ;
            'TB2Xml for Clipper por Jose Carlos da Rocha (jcrocha@sti.com.br)">' + CRLF)
    FWrite (xHtml, "</HEAD>" + CRLF)

    // setting colors - note than we are setting only background (BGCOLOR)
    // and text (TEXT) color, not the link colors (LINK/VLINK/ALINK)
    FWrite (xHtml, '<BODY BGCOLOR="'+ cSetClrBg + '"')
    FWrite (xHtml, ' TEXT="' + cSetClrText + '"')
    if ! Empty(cSetBgImage)
        // add backround image, if you specified one
        FWrite (xHtml, ' background="' + cSetBgImage + '"')
    endif
    FWrite (xHtml, '>' + CRLF)

    // all centered (including table) from here
    FWrite (xHtml, '<CENTER>' + CRLF)

    // define table display format (border and cell look)
    // and structure (number of columns)
    FWrite (xHtml, '<TABLE ')  // don't delete space chars from end
    FWrite (xHtml, 'BGCOLOR="'+ cSetClrTab + '" ')
    FWrite (xHtml, 'BORDER=2 ')
    FWrite (xHtml, 'FRAME=ALL ')
    FWrite (xHtml, 'CellPadding=4 ')
    FWrite (xHtml, 'CellSpacing=2 ')
    FWrite (xHtml, 'COLS=' + AllTrim(Str(oTB:ColCount)))
    // XML tags
    FWrite (xHtml, 'WIDTH="100%"'    + CRLF)
    FWrite (xHtml, 'ID="table"'      + CRLF)
    FWrite (xHtml, 'DATASRC=#xmldso' + CRLF)
    //
    FWrite (xHtml, '>'+CRLF)

    // write table title (in bold face)
    if ! Empty(cTitle)
        FWrite (xHtml, '<CAPTION ALIGN=TOP><B>' + cTitle + '</B></CAPTION>')
        FWrite (xHtml, CRLF)
    endif

    // output column headers
    FWrite (xHtml, "<THEAD>" + CRLF)
    FWrite (xHtml, "   <TR>" + CRLF)
    for i := 1 TO oTB:ColCount
        oCol  := oTB:GetColumn(i)
        cCell := oCol:Heading
        // for multi-line headings (those with semicolons in
        // header string) we are adding line break
        cCell := StrTran(cCell, ";", "<BR>")
        FWrite (xHtml, "      <TH COLSPAN=1 VALIGN=BOTTOM>" + cCell + "</TH>" + CRLF)
    next
    FWrite (xHtml, "   </TR>" + CRLF)
    FWrite (xHtml, "</THEAD>" + CRLF)

    // here comes the main loop which generate the table body
    FWrite (xHtml, "<TR>" + CRLF)
    for i := 1 TO oTB:ColCount
        oCol  := oTB:GetColumn(i)
        cCell := oCol:Heading
        // for multi-line headings (those with semicolons in
        // header string) we are adding line break
        cCell := StrTran(cCell, ";", "<BR>")
        FWrite (xHtml, "   <TD VALIGN=TOP><DIV DATAFLD=" + cCell + "></DIV></TD>" + CRLF)
    next
    FWrite (xHtml, "</TR>" + CRLF)

    // writing XML tail
    FWriteLn (xHtml, "</TABLE>" )
    FWriteLn (xHtml, "<APPLET ALIGN=BASELINE CODE=COM.MS.XML.DSO.XMLDSO.CLASS HEIGHT=0 WIDTH=0 ID=XMLDSO>")
    FWriteLn (xHtml, '<PARAM NAME="url" VALUE="' + cXmlFile + '">')
    FWriteLn (xHtml, "</APPLET>")
    FWriteLn (xHtml, "</CENTER>")
    FWriteLn (xHtml, "</BODY>"  )
    FWriteLn (xHtml, "</HTML>"  )
    FClose(xHtml)

    // here comes the main loop which generate the table body
    FWrite (xXml, '<?xml version="1.0"?>' + CRLF)
    FWrite (xXml, '<' + cTitle + '>' + CRLF)
    Eval (oTB:goTopBlock)   // start from the top
    do while .t.
       for i := 1 TO oTB:ColCount
           FWrite (xXml, '   <' + substr(cXmlFile,1,at('.',cXmlFile)-1) + '>' + CRLF)
           oCol     := oTB:GetColumn(i)
           uColData := Eval(oCol:Block)     // column data (of yet unknown type)
           do case
              case ValType(uColData) == "C" // characters
                   if Empty(uColData)
                       cCell := "&nbsp"     // if empty, display non-breaking space (&nbsp)
                                            // to prevent displaying "hole" in table
                   else
                       cCell  := uColData
                   endif
              case ValType(uColData) == "N" // numbers
                   if ! Empty(oCol:picture)
                       cCell := Transform (uColData, oCol:picture) // display numbers according to column picture
                   else
                       cCell := Str(uColData)
                   endif
                   if Empty(cCell)
                      cCell := "&nbsp"    // non-breaking space
                   endif
              case ValType(uColData) == "L" // logicals
                   cCell  := if (uColData, "Sim", "Nao")
              case ValType(uColData) == "D" // dates
                   if Empty(uColData)  // empty dates
                       cCell := "&nbsp"
                   else
                       cCell  := DToC(uColData)
                   endif
               otherwise
                   cCell  := "error"
           end case
           FWrite (xHtml, '      <'+uColData+'>' + cCell + '</'+uColData+'>')  // write cell
           FWrite (xXml, '   </' + substr(cXmlFile,1,at('.',cXmlFile)-1) + '>' + CRLF)
       next
       nTemp := Eval (oTB:SkipBlock, 1)
       if nTemp != 1   // it's the end, so we are getting out
           exit
       endif
    enddo
    Eval (oTB:goTopBlock)
    FWrite (xXml, '</' + cTitle + '>' + CRLF)
    FClose(xXml)

return .t.


Modificado 27/2/2012 para manter o código entre tags CODE.
Avatar de usuário

rochinha
Membro Master

Membro Master
 
Mensagens: 4146
Data de registro: 18 Ago 2003 20:43
Cidade/Estado: São Paulo - Brasil
Curtiu: 456 vezes
Mens.Curtidas: 175 vezes



Retornar para Contribuições, Dicas e Tutoriais

Quem está online

Usuários vendo este fórum: Nenhum usuário registrado online e 1 visitante


Faça uma doação para o forum
v
Olá visitante, seja bem-vindo ao Fórum Clipper On Line!
Efetue o seu login ou faça o seu Registro