Código: Selecionar todos
/*
*
* 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 := " " // if empty, display non-breaking space ( )
// 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 := " " // 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 := " "
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.