* TableToHTML.PRG * This is a simple program which writes a table to HTML. * The value of this is that it's suddenly much easier to send to someone * or to incorporate into a Word doc. * It provides significantly more flexibility than generating to Excel, in that: * It can be incorporated as a native Word table rather than an embedded spreadsheet. * The caller has the options of including header information or not and, with * user generated column headers, of providing other columns which will be filled in * manually. * 9/6/2001 JvS * PARAMETER IN/OUT OPT/REQ PURPOSE * tcHTMLOutputFile IN REQ (path) and name of HTML output file * txWorkArea IN OPT Numeric work area or alias * If unspecified, current work area is used. * tcHTMLHeader IN OPT Used to describe in HTML header * the file generated. * tlUseColumnHeaders IN OPT If .F. no table column headers are * generated. * If .T. and txColumnHeaders is not * empty, those are used for headers. * If .T. and txColumnHeaders is empty, * the field names are used. * txColumnHeaders IN OPT If not empty and tlUseColumnHeaders is * .T., table column headers are generated. * Format is a comma delimited list. * tlWarnOverwrite IN OPT Default = .F. * Whether to warn the user when * overwriting a file. * tcNotOKMessage IN/OUT OPT If passed as a parameter with a character value. * this routine passes back the value. * PASS BY REFERENCE in calling routine. * Otherwise (if not passed, or passed * as a non-character), this routine * reports the error. * * Invocations * 1. Simplest invocation * DO d:\utilities\TabletoHTML.prg WITH 'testhtml.htm' * This outputs only the data from the currently selected work area * to a file named 'testhtml.htm' in the current directory. * 2. DO d:\utilities\TabletoHTML.prg WITH 'testhtml.htm', 1 * This does the same as 1, except it selects the 1st work area. * 3. DO d:\utilities\TabletoHTML.prg WITH 'testhtml.htm', 'ACursor' * This does the same as 1, except it selects the work area with ACursor. * 4. DO d:\utilities\TabletoHTML.prg WITH 'testhtml.htm', 1, .T. * This does the same as 2, except it outputs the field names in the table column headers. * 5. DO d:\utilities\TabletoHTML.prg WITH 'testhtml.htm', 1, .T. * This does the same as 2, except it outputs the field names in the table column headers. * 6. DO d:\utilities\TabletoHTML.prg WITH 'testhtml.htm', 1, .T., .F., 'First,Second,Third,Fourth' * This does the same as 2, except it outputs caller-provided names for the column headers. * 7. DO d:\utilities\TabletoHTML.prg WITH 'testhtml.htm', 1, .T., .F., 'First,Second,Third,Fourth, Fifth' * This does the same as 5, except it outputs the caller-provided names for the column headers * and adds one column beyond the number of fields. * 8. DO d:\utilities\TabletoHTML.prg WITH 'testhtml.htm', 1, .T., .F., 'First,Second' * This does the same as 5, except it outputs the caller-provided column headers and outputs * only 2 fields. * 9. DO d:\utilities\TabletoHTML.prg WITH 'testhtml.htm', 1, .T., .F., 'First,Second', .T. * This does the same as 8, except it warns the user they are about to overwrite a file. LPARAMETER tcHTMLOutputFile, txWorkArea, tcHTMLHeader, tlUseColumnHeaders, ; txColumnHeaders, tlWarnOverwrite, tcNotOKMessage LOCAL lcOldPath, llDeletedWasOff, lcSafety, llSafetyWasOn LOCAL lcNotOKMessage, lcHTMLOutputFile, llReportHere, lcWorkAreaType, lnWorkArea LOCAL lnOldWorkArea LOCAL lxColumnHeaders, lnHeaders, lcColumns, laHeaders LOCAL lcHTMLOutputFile, lcProjectPathName LOCAL lcHTMLStart, lcHTMLEnd, lcTableStart, lcTableEnd, lcRowStart LOCAL lcRowEnd, lcCellStart, lcCellEnd, lcHeaderCells, lnLinesWritten DIMENSION laHeaders[1] #DEFINE EOL CHR(13) #DEFINE HARD_SPACE ' ' #DEFINE HTML_BEGIN '<' + 'html>' #DEFINE HTML_END '</' + 'html>' #DEFINE HTML_HEADER '<' + 'head>' + '</' + 'head>' #DEFINE HTML_BODY_BEGIN '<' + 'body>' #DEFINE HTML_BODY_END '</' + 'body>' #DEFINE HTML_TABLE_BEGIN '<' + 'table>' #DEFINE HTML_TABLE_END '</' + 'table>' #DEFINE HTML_BREAK '<' + 'br>' #DEFINE HTML_TABLE_HEADER_CELL_BEGIN '<' + 'th>' #DEFINE HTML_TABLE_HEADER_CELL_END '</' + 'th>' * Setup environment llReportHere = (TYPE ('tcNotOKMessage') = 'L') tcNotOKMessage = '' lcOldPath = SET ('PATH') SET PATH TO llDeletedWasOff = (SET ('DELETED') = 'OFF') IF llDeletedWasOff SET DELETED ON ENDIF llSafetyWasOn = (SET ('SAFETY') = 'ON') IF llSafetyWasOn <> tlWarnOverwrite && Test if safety setting is incorrect. lcSafety = IIF (llSafetyWasOn, 'OFF', 'ON') SET SAFETY &lcSafety ELSE lcSafety = '' ENDIF lnOldWorkArea = SELECT (0) * Test parameters IF TYPE ('tcHTMLOutputFile') <> 'C' tcNotOKMessage = 'tcHTMLOutputFile not a string.' ENDIF IF EMPTY (tcNotOKMessage) lcJustPath = JustPath (tcHTMLOutputFile) IF NOT EMPTY (lcJustPath) and NOT DIRECTORY(lcJustPath) && Allow current directory lcHTMLOutputFile = GetFile('HTM', 'Please choose an HTML output file in an existing directory.') IF EMPTY (lcHTMLOutputFile) tcNotOKMessage = 'No HTML output file chosen in an existing directory.' ENDIF ELSE lcHTMLOutputFile = ALLTRIM (tcHTMLOutputFile) ENDIF ENDIF * Continue validating parameters and transform them internal use. IF EMPTY (tcNotOKMessage) * Put appropriate extension on, if needed. IF RIGHT (UPPER (lcHTMLOutputFile), 4) <> '.HTM' lcHTMLOutputFile = lcHTMLOutputFile + '.HTM' ENDIF * Convert work area to proper format for our use. lcWorkAreaType = TYPE ('txWorkArea') DO CASE CASE NOT INLIST (lcWorkAreaType, 'C', 'N') lnWorkArea = SELECT (0) CASE lcWorkAreaType = 'C' IF USED (txWorkArea) lnWorkArea = SELECT (txWorkArea) ELSE tcNotOKMessage = 'Source table is not open.' ENDIF CASE lcWorkAreaType = 'N' IF BETWEEN (txWorkArea, 1, 32767) lnWorkArea = txWorkArea ELSE tcNotOKMessage = 'Work area is out of range.' ENDIF ENDCASE ENDIF IF EMPTY (tcNotOKMessage) IF EMPTY (tcHTMLHeader) lcHTMLHeader = 'Output of a table or cursor ' + ALIAS() ; + '. Created: ' + TRANSFORM(DATETIME()) ELSE lcHTMLHeader = tcHTMLHeader ENDIF SELECT (lnWorkArea) IF NOT USED () && Test that a table is open in work area. tcNotOKMessage = 'No table is open in selected work area.' ENDIF ENDIF IF EMPTY (tcNotOKMessage) lnFields = AFIELDS (laFields) && Get field info for variety of purposes * Co-ordinate Column header information provided by call with * fields available. Determine the number of columns to show: * If there are no user provided column headers, output all fields. * If there are user-provided column headers, output the number of fields * indicated by headers (if less than or equal). If there are more * user-provided column headers than fields, augment the field generation. IF tlUseColumnHeaders IF EMPTY (txColumnHeaders) lcHeaders = ALLTRIM (laFields[1, 1]) FOR X = 2 TO lnFields lcHeaders = lcHeaders + EOL + ALLTRIM (laFields[X, 1]) ENDFOR ELSE lcHeaders = STRTRAN (txColumnHeaders, ',', EOL) ENDIF lnHeaders = ALINES (laHeaders, lcHeaders) && Convert delimited string to array. ELSE lnHeaders = 0 ENDIF lnAddedFields = 0 && Modify if the header info adds beyond fields. IF lnHeaders > 0 IF lnFields < lnHeaders && Populate extra fields lnAddedFields = lnHeaders - lnFields lnOutputFields = lnFields ELSE lnOutputFields = lnHeaders ENDIF ELSE lnOutputFields = lnFields ENDIF * Setup HTML phrases lcHTMLStart = HTML_BEGIN + EOL + HTML_HEADER + EOL + HTML_BODY_BEGIN + EOL; + lcHTMLHeader + HTML_BREAK + HTML_BREAK lcHTMLEnd = HTML_BODY_END + EOL + HTML_END + EOL lcTableStart = '<' + 'table nowrap cols=' ; + TRANSFORM (2 + lnAddedFields) ; + ' cellpadding=5>' + EOL lcTableEnd = '</' + 'table>' + EOL lcRowStart = '<' + 'tr nowrap>' lcRowEnd = '</' + 'tr>' lcCellStart = '<' + 'td>' lcCellEnd = '</' + 'td>' * Create a string for extra cells, if any. lcExtraCells = '' IF lnAddedFields > 0 lcExtraCells = REPLICATE (lcCellStart + HARD_SPACE + lcCellEnd, lnAddedFields) ENDIF * Create table header HTML if indicated. lcHeaderCells = '' IF lnHeaders > 0 FOR X = 1 TO lnHeaders lcHeaderCells = lcHeaderCells + HTML_TABLE_HEADER_CELL_BEGIN; + ALLTRIM (laHeaders[X]) + HTML_TABLE_HEADER_CELL_END ENDFOR ENDIF * CORE PROCESSING lcHTML = lcHTMLStart + lcTableStart + lcHeaderCells && Create initial HTML string SCAN && Add rows lcRow = lcRowStart FOR lnField = 1 TO lnOutputFields lcRow = lcRow + lcCellStart + TRANSFORM (EVALUATE (laFields [lnField, 1])) + lcCellEnd ENDFOR lcHTML = lcHTML + lcRow + lcExtraCells + lcRowEnd ENDSCAN lcHTML = lcHTML + lcTableEnd + lcHTMLEnd && Create ending HTML string lnLinesWritten = STRTOFILE (lcHTML, lcHTMLOutputFile) && Write to file IF lnLinesWritten = 0 tcNotOKMessage = 'Unable to write to HTML output file.' ENDIF * END CORE PROCESSING ENDIF * Restore environment IF NOT EMPTY (lnOldWorkArea) SELECT (lnOldWorkArea) ENDIF IF NOT EMPTY (lcOldPath) SET PATH TO &lcOldPath ENDIF IF llDeletedWasOff SET DELETED OFF ENDIF IF NOT EMPTY (lcSafety) lcSafety = IIF (llSafetyWasOn, 'ON', 'OFF') SET SAFETY &lcSafety ENDIF * Report any errors, if indicated. IF llReportHere AND NOT EMPTY (tcNotOKMessage) WAIT WINDOW 'TabletoHTML: ' + tcNotOKMessage ELSE IF NOT EMPTY (tcNotOKMessage) tcNotOKMessage = 'TabletoHTML: ' + tcNotOKMessage ENDIF ENDIF ENDPROC