Clipper On Line • Ver Tópico - nfHTML - Gera arquivos HTML
Página 1 de 1

nfHTML - Gera arquivos HTML

MensagemEnviado: 06 Dez 2005 00:11
por rochinha
/*
* File......: TB2Html.prg
* Author....: Jovan Bulajic
* E-mail....: bulaja@sezampro.yu
* Version...: 1.0, 30/Apr/97
* History...:
* 02/Sep/96 - first version which I wrote for my own use
* 30/Apr/97 - I made few small changes and release first
* (and so far the only <g>) public version
*
* This is an original work by Jovan Bulajic and is placed
* in the public domain.
*
*/


/* $DOC$
* $FUNCNAME$
* TB2Html()
*
* $ONELINER$
* Generates HTML tables (documents) from TBrowse objects
*
* $SYNTAX$
* TB2Html( <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$
* TB2Html() 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.
* TB2Html 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
*
* TB2Html (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. SetTB2Html (<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 TB2Html (oTB, cHtmlFile, cTitle)

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

// argument checking
if ValType(oTB) != "O"
return .f.
endif
if Empty(cHtmlFile)
cHtmlFile := "TB2HTML.htm"
endif

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

// HTML header
FWrite (xHtml, '<HTML>' + CRLF)
FWrite (xHtml, '<HEAD>' + CRLF)
FWrite (xHtml, ' <TITLE>' + cTitle + '</TITLE>' + CRLF)
FWrite (xHtml, ' <meta name="Author" CONTENT="">' + CRLF)
FWrite (xHtml, ' <meta name="GENERATOR" CONTENT="' + ;
'TB2Html for Clipper by Jovan Bulajic (bulaja@sezampro.yu)">' + 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=4 ')
FWrite (xHtml, 'FRAME=ALL ')
FWrite (xHtml, 'CellPadding=4 ')
FWrite (xHtml, 'CellSpacing=2 ')
FWrite (xHtml, 'COLS=' + AllTrim(Str(oTB:ColCount)))
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, "<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 + CRLF)
next
FWrite (xHtml, "</TR>" + CRLF)
FWrite (xHtml, CRLF)

// here comes the main loop which generate the table body
FWrite (xHtml, '<TBODY>' + CRLF)
Eval (oTB:goTopBlock) // start from the top

do while .t.

FWrite (xHtml, "<TR>") // new table row

for i := 1 TO oTB:ColCount
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
cAlign := "<TD Align=Left>" // text fields are left aligned
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
cAlign := "<TD Align=Right>"
/*
Sometimes you may prefer aligning cell contents
to specific character (e.g. decimal point/comma).
In that cases, you can use something like this:
if "," $ cCell
cAlign := "<TD Align=Char Char=,>"
endif
*/
case ValType(uColData) == "L" // logicals
cCell := if (uColData, "Sim", "Nao")
cAlign := "<TD ALIGN=CENTER>" // NOTE: if you prefer T/F style, change above line to
// cCell := if (uColData, "T", "F")
case ValType(uColData) == "D" // dates
if Empty(uColData) // empty dates
cCell := "&nbsp"
else
cCell := DToC(uColData)
endif
cAlign := "<TD ALIGN=CENTER>"
otherwise
cCell := "error"
cAlign := "<TD ALIGN=CENTER>"
end case
FWrite (xHtml, cAlign + cCell) // write cell
next

FWrite (xHtml, "</TR>" + CRLF) // end of row

nTemp := Eval (oTB:SkipBlock, 1)
if nTemp != 1 // it's the end, so we are getting out
exit
endif

end do // main loop

Eval (oTB:goTopBlock) // set TBrowse back to top

// writing HTML tail
FWriteLn (xHtml, "</TBODY>" )
FWriteLn (xHtml, "</TABLE>" )
FWriteLn (xHtml, "</CENTER>")
FWriteLn (xHtml, "</BODY>" )
FWriteLn (xHtml, "</HTML>" )
FClose(xHtml)

return .t.

/*
* Arquivo...: TB2Xml.prg
* Autor.....: Jose Carlos da Rocha
* E-mail....: jcrocha@sti.com.br
* Site......: jcrocha@sti.com.br
* Version...: 1.0, 18/Ago/2000
* Historico.:
* 18/Ago/2000 - primeira vers~aogera arquivos basicos
*
*/
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"
endif
cXmlFile := cHtmlFile
// creating new Xml (.HTM) file
xHtml := FCreate (cHtmlFile+".htm", FC_NORMAL)
if FError() != 0
beep(); mensagem('Nao foi possivel gerar '+cHtmlFile,5)
return .f.
endif
xXml := FCreate (cXmlFile +".xml", FC_NORMAL)
if FError() != 0
beep(); mensagem('Nao foi possivel gerar '+cXmlFile ,5)
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="' + AllTrim(cXmlFile)+'.XML' + '">')
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, '<' + AllTrim(cTitle) + '>' + CRLF)
Eval (oTB:goTopBlock) // start from the top
do while .t.
FWrite (xXml, ' <' + AllTrim(cXmlFile) + '>' + CRLF)
for i := 1 TO oTB:ColCount
oCol := oTB:GetColumn(i)
cHeading := oCol:Heading
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)
cCell := " " // 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
cCell := " " // if empty, display non-breaking space (&nbsp)
endif
case ValType(uColData) == "L" // logicals
cCell := if (uColData, "Sim", "Nao")
case ValType(uColData) == "D" // dates
if Empty(uColData) // empty dates
//cCell := "&nbsp"
cCell := " " // if empty, display non-breaking space (&nbsp)
else
cCell := DToC(uColData)
endif
otherwise
cCell := "error"
end case
FWrite (xXml, ' <'+cHeading+'>' + cCell + '</'+cHeading+'>' + CRLF)
next
FWrite (xXml, ' </' + AllTrim(cXmlFile) + '>' + CRLF)
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, '</' + AllTrim(cTitle) + '>' + CRLF)
FClose(xXml)
return .t.