*!* zVfp_To_Excel_XML.prg *!* Kevin V. Emmrich (based on prior work by Christof Wollenhaupt) *!* www.jkt9000.com *!* Probably make a nice class so it is easier to set widths, fonts, colors, shading, etc -- but this is quick and dirty *!* I used the article by Christof Wollenhaupt at http://www.foxpert.com/docs/excel.en.htm as my starting point (he did most of the hard work!). LPARAMETERS lcCursorDBF, lcXLSFileName *** lcCursor is open and the alias is passed *** lcXLSFilename is the the xls file we are creating The full path and name have been passed. IF TYPE("lcCursorDBF") = "L" OR TYPE("lcXLSFileName") = "L" && didn't pass what we needed! WAIT WINDOW 'goodbye' && this will causes errors so gotta trap better. RETURN ENDIF *** Test XLS creation Local lcFile Local lcRows, lnField, luValue, lcStyle, lcData Set Point To "." && I never used this before! *** Can I get by with just three styles? a) headers row --21 , b) large text fields --22, c) everything else -- 23 *!* TEXT TO XmlHeader *!* <?xml version="1.0"?> *!* <Workbook xmlns="urn:schemas-microsoft-com:office:spreadsheet" *!* xmlns:x="urn:schemas-microsoft-com:office:excel" *!* xmlns:ss="urn:schemas-microsoft-com:office:spreadsheet"> *!* endtext *!* TEXT TO lcStyles *!* <Styles> *!* <Style ss:ID="Default" ss:Name="Normal"> *!* <Alignment ss:Vertical="Bottom"/> *!* </Style> *!* <Style ss:ID="s21"> *!* <Alignment ss:Vertical="Bottom"/> *!* <Font ss:Size="12" ss:Bold="1"/> *!* </Style> *!* <Style ss:ID="s22"> *!* <Alignment ss:Vertical="Bottom" ss:WrapText="1"/> *!* </Style> *!* <Style ss:ID="s23" ss:Name="Normal"> *!* <Alignment ss:Vertical="Bottom"/> *!* </Style> *!* </Styles> *!* endtext lcXMLFile = lcXLSFileName && has to be passed *!* lcXMLFile = "c:\temp\wcAttachments\" + lcStemName+ ".xls" If File(m.lcXMLFile) Erase (m.lcXMLFile) Endif *** I am testing for all these fields, but I have not really run into data yet with Q or V - there are potential errors *** Currency caused an error since it sent the "$" along and excel didn't like that as a number *!* Field Types *!* BLOB = W *!* Char = C *!* Char(Binary) = C *!* Currency = Y *!* Date = D *!* DATETIME = T *!* DOUBLE = B *!* FLOAT = F *!* GENERAL = G *!* INTeger = I *!* INTeger AutoInc = I *!* LOGICAL = L *!* MEMO = M *!* Number = N *!* VARBINary = Q *!* VarChar = V SELECT (lcCursorDBF) && open alias passed from calling program Set Deleted On LOCATE *********************** First do columns widths based on type and expected field sizes ***************************** *** Let's determine the column widths and such *!* IF Character AND 10 OR less in width (or numeric) use ==> <Column ss:AutoFitWidth="0" ss:Width="80"/> *!* IF character AND less than 40 use ==> <Column ss:AutoFitWidth="0" ss:Width="160"/> *!* IF character AND bigger than 40 use memo below (later) ==> <Column ss:AutoFitWidth="0" ss:Width="160"/> *!* IF memo use ==> <Column ss:StyleID="s21" ss:AutoFitWidth="0" ss:Width="240"/> m.lcColumns = "" For lnField = 1 To Fcount() lcFieldName = Field(m.lnField) Do Case Case Type(Field(lnField))$"C" And Fsize(Field(lnField)) <11 m.lcColumns = m.lcColumns + [<Column ss:AutoFitWidth="0" ss:Width="80"/>] + Chr(013) Case Type(Field(lnField))$"CQV" && AND FSIZE(FIELD(lnField)) <40 m.lcColumns = m.lcColumns + [<Column ss:AutoFitWidth="0" ss:Width="160"/>] + Chr(013) *!* Case Type(Field(lnField))$"CQV" AND FSIZE(FIELD(lnField)) >40 && no time to test this situation yet *!* m.lcColumns = m.lcColumns + [<Column ss:AutoFitWidth="0" ss:StyleID="s22" ss:Width="213.75"/>] + Chr(013) Case Type(Field(lnField))$"M" && AND FSIZE(FIELD(lnField)) >40 m.lcColumns = m.lcColumns + [<Column ss:AutoFitWidth="0" ss:StyleID="s22" ss:Width="240"/>] + Chr(013) Otherwise m.lcColumns = m.lcColumns + [<Column ss:AutoFitWidth="0" ss:Width="160"/>] + Chr(013) Endcase ENDFOR *****************/ End columns ************************************************************************************** ***************** Header Row (table column names) ************************************************************************************** lcRows = "" *** Let's Do the Header Row lcRows = m.lcRows + "<Row>" For lnField = 1 To Fcount() lcFieldName = PROPER(Field(m.lnField)) lcStyle = [<Cell ss:StyleID="s21">] lcData = [<Data ss:Type="String">]+Strconv(Alltrim(m.lcFieldName),9)+[</Data>] lcRows = m.lcRows + ; lcStyle+m.lcData+[</Cell>] Endfor lcRows = m.lcRows + "</Row>" ***************** /Header Row ************************************************************************************** ***************** and here is all the data rows ************************************************************************************** Scan lcRows = m.lcRows + "<Row>" For lnField = 1 To Fcount() luValue = Evaluate(Field(m.lnField)) Do Case CASE ALLTRIM(UPPER(Field(m.lnField))) == UPPER("Timestamp_Column") OR ALLTRIM(UPPER(Field(m.lnField))) == UPPER("cPassword") lcString = SPACE(5) && let's remove any illegal characters that will confuse the simple XML -- like "<>" lcData = ; [<Cell ss:StyleID="s23">]+[<Data ss:Type="String">]+lcString+[</Data>]+[</Cell>] Case Inlist(type(Field(m.lnField)),"C","Q","V") *!* STRCONV(,9) = STRCONV(,9) - 1 the 9 Converts double-byte characters in cExpression to UTF-8 lcString = Strconv(Alltrim(m.luValue),9) && let's remove any illegal characters that will confuse the simple XML -- like "<>" lcString = zRemoveEscapeChars(lcString) lcData = ; [<Cell ss:StyleID="s23">]+[<Data ss:Type="String">]+lcString+[</Data>]+[</Cell>] Case Inlist(type(Field(m.lnField)),"M") lcString = Strconv(Alltrim(m.luValue),9) && let's remove any illegal characters that will confuse the simple XML -- like "<>" lcString = zRemoveEscapeChars(lcString) lcData = ; [<Cell ss:StyleID="s22">]+[<Data ss:Type="String">]+lcString+[</Data>]+[</Cell>] Case Inlist(type(Field(m.lnField)),"L") lcData = ; [<Cell ss:StyleID="s23">]+[<Data ss:Type="String">]+IIF(Transform(m.luValue)==".T.","TRUE","FALSE")+[</Data>]+[</Cell>] Case Inlist(type(Field(m.lnField)),"N","B","F","I") lcData = ; [<Cell ss:StyleID="s23">]+[<Data ss:Type="Number">]+Transform(Nvl(m.luValue,0))+[</Data>]+[</Cell>] Case Inlist(type(Field(m.lnField)),"Y") lcData = ; [<Cell ss:StyleID="s23">]+[<Data ss:Type="String">]+Transform(Nvl(m.luValue,0))+[</Data>]+[</Cell>] Case Inlist(type(Field(m.lnField)),"D","T") luValue = LEFT(Transform(Nvl(m.luValue,"")),10) lcData = ; [<Cell ss:StyleID="s23">]+[<Data ss:Type="String">]+luValue+[</Data>]+[</Cell>] Otherwise LOOP && skipping blobs and generals ENDCASE lcRows = m.lcRows +m.lcData *!* lcRows = m.lcRows + [<Cell ss:StyleID="]+m.lcStyle+[">]+m.lcData+[</Cell>] Endfor lcRows = m.lcRows + "</Row>" ENDSCAN ***************** /Data Rows ************************************************************************************** **************** OK, let's build the XML file and strtoFile() if XLS (or XLSX) ************************************************************************************** Local lcXML TEXT to m.lcXML Noshow Textmerge <?xml version="1.0"?> <Workbook xmlns="urn:schemas-microsoft-com:office:spreadsheet" xmlns:x="urn:schemas-microsoft-com:office:excel" xmlns:ss="urn:schemas-microsoft-com:office:spreadsheet"> <Styles> <Style ss:ID="Default" ss:Name="Normal"> <Alignment ss:Vertical="Bottom"/> </Style> <Style ss:ID="s21"> <Alignment ss:Vertical="Bottom"/> <Font ss:Size="12" ss:Bold="1"/> </Style> <Style ss:ID="s22"> <Alignment ss:Vertical="Bottom" ss:WrapText="1"/> </Style> <Style ss:ID="s23"> <Alignment ss:Vertical="Bottom"/> </Style> </Styles> <Worksheet ss:Name="Sheet1"> <Table><<m.lcColumns>><<m.lcRows>></Table> </Worksheet> <!-- Placeholder for Additional Sheet --> </Workbook> ENDTEXT Strtofile(m.lcXML,m.lcXMLFile) return *********************************************************************************** function zRemoveEscapeChars() Lparameter cpassedtext *!* **** Important Note: Probably have to check for xml control characters like <,>,&, " *!* When writing parsed data to XML: *!* quote (") --> " *!* apostrophe (') --> ' *!* ampersand (&) --> & *!* less than (<) --> < *!* greater than (>) --> > *!* slash (\) --> No escape required *!* space --> No escape required *!* When writing unparsed data to XML: *!* quote (") --> \" *!* apostrophe (') --> ' *!* ampersand (&) --> & *!* less than (<) --> < *!* greater than (>) --> > *!* slash (\) --> \\ *!* space --> No escape required If "&" $ cpassedtext cpassedtext = STRTRAN(TRIM(cpassedtext),"&","&") Endif If ">" $ cpassedtext cpassedtext = STRTRAN(cpassedtext,">",">") Endif If "<" $ cpassedtext cpassedtext = STRTRAN(cpassedtext, "<", "<") Endif Return cpassedtext
