&ANALYZE-SUSPEND _VERSION-NUMBER AB_v10r12 &ANALYZE-RESUME &ANALYZE-SUSPEND _UIB-CODE-BLOCK _CUSTOM _DEFINITIONS Procedure /*------------------------------------------------------------------------ File : Purpose : Syntax : Description : Author(s) : Created : Notes : ----------------------------------------------------------------------*/ /* This .W file was created with the Progress AppBuilder. */ /*----------------------------------------------------------------------*/ /* This procedure will create an xml file that can be opened by Excel and will be seen as a spreadsheet complete with formatting, hyperlinks etc. The basics of this program are quite simple and it can create a spreadsheet without any particular care in the design of the temp table. There are a variety of features that can be implemneted by setting certain temp-table attributes. If the createHeader option is enabled, a header will be created for each column in the temp-table. The header will use the column-label attribute of each temp-table field for its content. To skip a field in the temp-table set the column-label attribute to "". Hyperlinks can be enabled by adding a character column named hyperlink_info to your temp-table. The attributes of the column should be set as follows: COLUMN-LABEL = "" LABEL = The name of the column that will contain the hyperlink. This will be the field name. This also supports a comma delimited list of columns if more than one hyperlink column is needed in the spreadsheet. BUFFER-VALUE = The data in this column must represent the URL of the hyperlink. i.e. www.progress.com?test=page2. This can be a comma delimited list of values if more than one hyperlink column is required. Hyperlinks only work correctly on fields that don't require special formatting like strings and integers. If a Hyperlink is needed on another data type like Date or a formatted decimal you will need to create a custom style that both sets the color and underline and the appropriate format for the data type. The format attribute is mostly ignored by this procedure. There are three uses of the format attribute currently supported. 1) In a decimal field, if the format ends with either ".99" or ".99)" we will automatically use a 2 decimal excel format. This is mostly used for fields representing money. If the decimal field has a % (percent) character in the format expression, we will automatically format as a percentage in Excel. 2) In character fields, the width of the column will be based upon the format of the field. The procedure uses a factor of 6 to change format characters into points. This appears close but since we're dealing with proportional fonts there's no real accuracy to this. No matter what the format of a character field, the entire content will always appear. This is used ONLY to set the column width. 3) If you use the special format value "xlNumber" on a character field, we will attempt to turn any values in this field into numbers. Note that number and date fields use the autofit attribute and will automatically have properly sized columns. There are a number of internal procedures that can be used to define a custom style for a column. The example code below demonstrates creating a style named "redText" that will make the text in the column red and bold. This can be used for Font attributes numberFormats or anything else valid in a style. An additional procedure allows the column width to be set. This is an alternative to the use of the format attribute. The size is in points. Microsoft reference docs are here: http://msdn2.microsoft.com/en-us/library/Aa140066(office.10).aspx Here is an example procedure that can call this program: CREATE WIDGET-POOL. DEF TEMP-TABLE foo FIELD testdate AS DATE COLUMN-LABEL "my date" FIELD testchar AS CHAR COLUMN-LABEL "A Test Char" FORMAT "xlWidth=100" FIELD testfloat AS DEC FORMAT "(zzzzzz9.99999)" COLUMN-LABEL "A test dec" FIELD testmoney AS DEC DECIMALS 2 COLUMN-LABEL "Money" FIELD testchar2 AS CHAR COLUMN-LABEL "Is This red" FORMAT "X(20)" FIELD testchar3 AS CHAR COLUMN-LABEL "Really a number" FORMAT "xlNumber" FIELD testlog AS LOG COLUMN-LABEL "A Logical" FIELD hyperlink_info as CHAR COLUMN-LABEL "" LABEL "testfloat" FIELD testdatetime AS DATETIME. DEF temp-table topRows FIELD col1 AS CHAR FORMAT "xlBold" FIELD col2 AS CHAR FIELD col3 AS CHAR FORMAT "xlDefault". DEF VAR pHand AS HANDLE. DEF VAR thand AS HANDLE. DEF VAR i AS INT. DEF VAR hXdoc AS HANDLE. DEF VAR hRows AS HANDLE. DEF VAR vLong AS LONGCHAR NO-UNDO. DO i = 1 TO 100: CREATE foo. ASSIGN testdate = TODAY + i testchar = "testvalue> À" + STRING(i) testchar2 = "testchar test x€£®" + chr(192) + STRING(i) testchar3 = "2345655567" + STRING(i) testfloat = 1234 + (i / 3.2) testmoney = 234 + .01 + i hyperlink_info = "http://www.progress.com?page=" + string(i) testlog = i MOD(2) = 0 testdatetime = NOW . END. CREATE topRows. ASSIGN col1 = "Test for col1 that is very long and might wrap" col2 = "xlNoCell" col3 = "xlNoCell". CREATE topRows. ASSIGN col1 = "Row 2 col1" col2 = "Row 2 col2" col3 = "xlNoCell". CREATE toprows. ASSIGN col1 = "Row3 col1" col2 = "row3 col2" col3 = "row3 col3". CREATE toprows. CREATE toprows. testlog = ?. testchar3 = "XXSSLLKK". thand = TEMP-TABLE foo:HANDLE. hRows = TEMP-TABLE topRows:HANDLE. /*CREATE X-DOCUMENT hXdoc.*/ RUN xmlspreadsax.p PERSISTENT SET pHand. RUN addStyle IN pHand ("redText"). RUN addStyleElement IN pHand ("redText","Font"). RUN addStyleElementAttribute IN pHand ("redText","Font","Color","#FF0000"). RUN addStyleElementAttribute IN pHand ("redText","Font","Bold","1"). RUN addStyleElement IN pHand ("redText","Alignment"). RUN addStyleElementAttribute IN pHand ("redText","Alignment","WrapText","1"). RUN assignStyleToColumn IN pHand ("redText","testchar2"). RUN setColumnWidth IN pHand ("testchar",120). RUN assignTopRows IN pHand( TABLE-HANDLE hRows BY-REFERENCE). RUN makeDocument IN pHand ( TABLE-HANDLE thand BY-REFERENCE, /* handle to temp-table */ TRUE, /* Include a header? */ "MySheet", /* The name of the worksheet */ "c:\temp\test.xml"). /* The output filename */ DELETE PROCEDURE pHand. pHand = ?. */ CREATE WIDGET-POOL. /* *************************** Definitions ************************** */ DEFINE VARIABLE hTempTable AS HANDLE NO-UNDO. DEF VAR hTopRowTable AS HANDLE NO-UNDO. DEF VAR hSaxWriter AS HANDLE NO-UNDO. DEF TEMP-TABLE tt-style FIELD styleName AS CHAR. DEF TEMP-TABLE tt-styleElement FIELD styleName AS CHAR FIELD elementName AS CHAR. DEF TEMP-TABLE tt-styleElementAttribute FIELD styleName AS CHAR FIELD elementName AS CHAR FIELD AttributeName AS CHAR FIELD AttributeValue AS CHAR. DEF TEMP-TABLE tt-ColumnStyle FIELD styleName AS CHAR FIELD columnName AS CHAR. DEF TEMP-TABLE tt-columnwidth FIELD columnName AS CHAR FIELD columnWidth AS INT. /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME &ANALYZE-SUSPEND _UIB-PREPROCESSOR-BLOCK /* ******************** Preprocessor Definitions ******************** */ &Scoped-define PROCEDURE-TYPE Procedure &Scoped-define DB-AWARE no /* _UIB-PREPROCESSOR-BLOCK-END */ &ANALYZE-RESUME /* ************************ Function Prototypes ********************** */ &IF DEFINED(EXCLUDE-ConvUTF-8) = 0 &THEN &ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION-FORWARD ConvUTF-8 Procedure FUNCTION ConvUTF-8 RETURNS CHARACTER ( INPUT pChar AS CHAR ) FORWARD. /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME &ENDIF /* *********************** Procedure Settings ************************ */ &ANALYZE-SUSPEND _PROCEDURE-SETTINGS /* Settings for THIS-PROCEDURE Type: Procedure Allow: Frames: 0 Add Fields to: Neither Other Settings: CODE-ONLY COMPILE */ &ANALYZE-RESUME _END-PROCEDURE-SETTINGS /* ************************* Create Window ************************** */ &ANALYZE-SUSPEND _CREATE-WINDOW /* DESIGN Window definition (used by the UIB) CREATE WINDOW Procedure ASSIGN HEIGHT = 15 WIDTH = 60. /* END WINDOW DEFINITION */ */ &ANALYZE-RESUME &ANALYZE-SUSPEND _UIB-CODE-BLOCK _CUSTOM _MAIN-BLOCK Procedure /* *************************** Main Block *************************** */ /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME /* ********************** Internal Procedures *********************** */ &IF DEFINED(EXCLUDE-addStyle) = 0 &THEN &ANALYZE-SUSPEND _UIB-CODE-BLOCK _PROCEDURE addStyle Procedure PROCEDURE addStyle : /*------------------------------------------------------------------------------ Purpose: Parameters: Notes: ------------------------------------------------------------------------------*/ DEFINE INPUT PARAMETER p-stylename AS CHAR NO-UNDO. FIND tt-style WHERE tt-Style.styleName = p-styleName NO-ERROR. IF NOT AVAILABLE tt-Style THEN DO: CREATE tt-Style. tt-style.styleName = p-stylename. END. END PROCEDURE. /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME &ENDIF &IF DEFINED(EXCLUDE-addStyleElement) = 0 &THEN &ANALYZE-SUSPEND _UIB-CODE-BLOCK _PROCEDURE addStyleElement Procedure PROCEDURE addStyleElement : /*------------------------------------------------------------------------------ Purpose: Parameters: Notes: ------------------------------------------------------------------------------*/ DEFINE INPUT PARAMETER p-stylename AS CHAR NO-UNDO. DEF INPUT PARAMETER p-elementname AS CHAR NO-UNDO. FIND tt-styleElement WHERE tt-styleElement.styleName = p-styleName AND tt-StyleElement.elementName = p-elementName NO-ERROR. IF NOT AVAILABLE tt-styleElement THEN DO: CREATE tt-styleElement. ASSIGN tt-styleElement.styleName = p-stylename tt-styleElement.elementName = p-elementName. END. END PROCEDURE. /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME &ENDIF &IF DEFINED(EXCLUDE-addStyleElementAttribute) = 0 &THEN &ANALYZE-SUSPEND _UIB-CODE-BLOCK _PROCEDURE addStyleElementAttribute Procedure PROCEDURE addStyleElementAttribute : /*------------------------------------------------------------------------------ Purpose: Parameters: Notes: ------------------------------------------------------------------------------*/ DEFINE INPUT PARAMETER p-stylename AS CHAR NO-UNDO. DEF INPUT PARAMETER p-elementname AS CHAR NO-UNDO. DEF INPUT PARAMETER p-attributeName AS CHAR NO-UNDO. DEF INPUT PARAMETER p-attributeValue AS CHAR NO-UNDO. FIND tt-styleElementAttribute WHERE tt-styleElementAttribute.styleName = p-styleName AND tt-StyleElementAttribute.elementName = p-elementName AND tt-StyleElementAttribute.attributeName = p-attributeName AND tt-StyleElementAttribute.AttributeValue = p-attributeValue NO-ERROR. IF NOT AVAILABLE tt-styleElementAttribute THEN DO: CREATE tt-styleElementAttribute. ASSIGN tt-styleElementAttribute.styleName = p-stylename tt-styleElementAttribute.elementName = p-elementName tt-StyleElementAttribute.attributeName = p-attributeName tt-StyleElementAttribute.AttributeValue = p-attributeValue . END. END PROCEDURE. /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME &ENDIF &IF DEFINED(EXCLUDE-assignStyleToColumn) = 0 &THEN &ANALYZE-SUSPEND _UIB-CODE-BLOCK _PROCEDURE assignStyleToColumn Procedure PROCEDURE assignStyleToColumn : /*------------------------------------------------------------------------------ Purpose: Parameters: Notes: ------------------------------------------------------------------------------*/ DEF INPUT PARAMETER p-StyleName AS CHAR. DEF INPUT PARAMETER p-columnName AS CHAR NO-UNDO. FIND tt-columnStyle WHERE tt-ColumnStyle.styleName = p-StyleName AND tt-ColumnStyle.columnName = p-columnName NO-ERROR. IF NOT AVAILABLE tt-columnStyle THEN DO: CREATE tt-columnStyle. ASSIGN tt-columnStyle.stylename = p-styleName tt-columnStyle.columnName = p-columnName. END. END PROCEDURE. /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME &ENDIF &IF DEFINED(EXCLUDE-assignTopRows) = 0 &THEN &ANALYZE-SUSPEND _UIB-CODE-BLOCK _PROCEDURE assignTopRows Procedure PROCEDURE assignTopRows : /*------------------------------------------------------------------------------ Purpose: Parameters: Notes: ------------------------------------------------------------------------------*/ DEF INPUT PARAMETER TABLE-HANDLE FOR htopRowTable. END PROCEDURE. /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME &ENDIF &IF DEFINED(EXCLUDE-createColumns) = 0 &THEN &ANALYZE-SUSPEND _UIB-CODE-BLOCK _PROCEDURE createColumns Procedure PROCEDURE createColumns : /*------------------------------------------------------------------------------ Purpose: Parameters: Notes: ------------------------------------------------------------------------------*/ DEF VAR hBuff AS HANDLE NO-UNDO. DEF VAR i AS INT NO-UNDO. DEF VAR decstring AS CHAR NO-UNDO. DEF VAR hyperlinknumber AS INT NO-UNDO. DEF VAR vChars AS INT NO-UNDO. DEF VAR charsToPoints AS INT INIT 6 NO-UNDO. hBuff = hTempTable:DEFAULT-BUFFER-HANDLE. DO i = 1 TO hBuff:NUM-FIELDS: /* If the column-label is set to then skip the column from the data export */ IF hBuff:BUFFER-FIELD(i):COLUMN-LABEL = "" THEN NEXT. hyperLinkNumber = LOOKUP(hBuff:BUFFER-FIELD(i):NAME,hbuff:BUFFER-FIELD("hyperlink_info"):LABEL) NO-ERROR. hSaxWriter:WRITE-EMPTY-ELEMENT("Column"). /* If we find a custom style for this column apply it */ FIND tt-columnstyle WHERE tt-columnStyle.columnName = string(hBuff:BUFFER-FIELD(i):NAME) NO-ERROR. IF AVAILABLE tt-columnstyle THEN DO: hSaxWriter:INSERT-ATTRIBUTE("ss:StyleID",tt-columnStyle.styleName). END. /* If no custom style and this column gets hyperlinked, apply the hyperlink style */ ELSE IF hyperlinkNumber GT 0 AND hyperLinkNumber NE ? THEN DO: hSaxWriter:INSERT-ATTRIBUTE("ss:StyleID","Hyperlink"). END. /* Otherwise, figure out what style to apply based upon the data type */ ELSE DO: CASE hBuff:BUFFER-FIELD(i):DATA-TYPE: WHEN "date" THEN DO: hSaxWriter:INSERT-ATTRIBUTE("ss:StyleID","Date"). END. WHEN "datetime" THEN DO: hSaxWriter:INSERT-ATTRIBUTE("ss:StyleID","DateTime"). END. WHEN "datetime-tz" THEN DO: hSaxWriter:INSERT-ATTRIBUTE("ss:StyleID","DateTime"). END. WHEN "DECIMAL" THEN DO: IF hBuff:BUFFER-FIELD(i):FORMAT MATCHES "*%*" THEN hSaxWriter:INSERT-ATTRIBUTE("ss:StyleID","Percent2"). ELSE DO: decstring = ENTRY(2,hBuff:BUFFER-FIELD(i):FORMAT,".") NO-ERROR. IF hBuff:BUFFER-FIELD(i):DECIMALS EQ 2 OR decstring EQ "99" OR decstring EQ "99)" THEN hSaxWriter:INSERT-ATTRIBUTE("ss:StyleID","Decimal2"). ELSE hSaxWriter:INSERT-ATTRIBUTE("ss:StyleID","Default"). END. END. WHEN "logical" THEN DO: hSaxWriter:INSERT-ATTRIBUTE("ss:StyleID","Logical"). END. OTHERWISE DO: hSaxWriter:INSERT-ATTRIBUTE("ss:StyleID","Default"). END. END CASE. END. /* This is an alternate way to set the column width and depends upon the use of the setColumnWidth procedure */ FIND tt-columnWidth WHERE tt-columnwidth.columnName = string(hBuff:BUFFER-FIELD(i):NAME) NO-ERROR. IF AVAILABLE tt-columnwidth THEN hSaxWriter:INSERT-ATTRIBUTE("ss:Width",string(tt-columnwidth.columnwidth)) NO-ERROR. ELSE DO: /* autofitwidth only works for numbers and dates */ IF hBuff:BUFFER-FIELD(i):DATA-TYPE NE "CHARACTER" THEN hSaxWriter:INSERT-ATTRIBUTE("AutoFitWidth","1") NO-ERROR. /* It's a character, use the format attribute to set the width */ ELSE DO: vChars = LENGTH(STRING(" ",hBuff:BUFFER-FIELD(i):FORMAT)) NO-ERROR. IF vChars NE ? THEN hSaxWriter:INSERT-ATTRIBUTE("ss:Width",STRING(vChars * charsToPoints)) NO-ERROR. END. END. END. END PROCEDURE. /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME &ENDIF &IF DEFINED(EXCLUDE-createHeader) = 0 &THEN &ANALYZE-SUSPEND _UIB-CODE-BLOCK _PROCEDURE createHeader Procedure PROCEDURE createHeader : /*------------------------------------------------------------------------------ Purpose: Parameters: Notes: ------------------------------------------------------------------------------*/ DEF VAR hBuff AS HANDLE. DEF VAR i AS INT NO-UNDO. hBuff = hTempTable:DEFAULT-BUFFER-HANDLE. hSaxWriter:START-ELEMENT("Row"). hSaxWriter:INSERT-ATTRIBUTE("ss:StyleID","Header"). DO i = 1 TO hBuff:NUM-FIELDS: /* If the column-label is set to then skip the column from the data export */ IF hBuff:BUFFER-FIELD(i):COLUMN-LABEL = "" THEN NEXT. hSaxWriter:START-ELEMENT("Cell"). hsaxWriter:START-ELEMENT("Data"). hSaxWriter:INSERT-ATTRIBUTE("ss:Type","String"). hSaxWriter:WRITE-CHARACTERS(convUTF-8(hBuff:BUFFER-FIELD(i):COLUMN-LABEL)). hSaxWriter:END-ELEMENT("Data"). hSaxWriter:END-ELEMENT("Cell"). END. hSaxWriter:END-ELEMENT("Row"). END PROCEDURE. /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME &ENDIF &IF DEFINED(EXCLUDE-createRows) = 0 &THEN &ANALYZE-SUSPEND _UIB-CODE-BLOCK _PROCEDURE createRows Procedure PROCEDURE createRows : /*------------------------------------------------------------------------------ Purpose: Parameters: Notes: ------------------------------------------------------------------------------*/ DEF VAR hBuff AS HANDLE. DEF VAR hQuery AS HANDLE. DEF VAR i AS INT NO-UNDO. DEF VAR hyperlinkNumber AS INT NO-UNDO. DEF VAR testNum AS DEC NO-UNDO. DEF INPUT PARAMETER hTT AS HANDLE. IF NOT VALID-HANDLE(htt) THEN RETURN. /*hBuff = hTempTable:DEFAULT-BUFFER-HANDLE.*/ hBuff = hTT:DEFAULT-BUFFER-HANDLE. CREATE QUERY hQuery. hQuery:SET-BUFFERS(hBuff). hQuery:QUERY-PREPARE("for each " + /*hTempTable*/ hTT:NAME). hQuery:QUERY-OPEN. REPEAT: hQuery:GET-NEXT(). IF hQuery:QUERY-OFF-END THEN LEAVE. hSaxWriter:START-ELEMENT("Row"). DO i = 1 TO hBuff:NUM-FIELDS: IF hBuff:BUFFER-FIELD(i):COLUMN-LABEL = "" THEN NEXT. IF hBuff:BUFFER-FIELD(i):BUFFER-VALUE = "xlNoCell" THEN NEXT. hSaxWriter:START-ELEMENT("Cell"). RUN setCellAttrs(hBuff,i). hSaxWriter:START-ELEMENT("Data"). RUN setDataAttrs(hbuff,i). RUN setDataValues(hBuff,i). hSaxWriter:END-ELEMENT("Data"). hSaxWriter:END-ELEMENT("Cell"). END. /* hbuff:num-fields */ hSaxWriter:END-ELEMENT("Row"). END. /* repeat */ hQuery:QUERY-CLOSE(). DELETE OBJECT hQuery. END PROCEDURE. /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME &ENDIF &IF DEFINED(EXCLUDE-createStyles) = 0 &THEN &ANALYZE-SUSPEND _UIB-CODE-BLOCK _PROCEDURE createStyles Procedure PROCEDURE createStyles : /*------------------------------------------------------------------------------ Purpose: Parameters: Notes: ------------------------------------------------------------------------------*/ hsaxWriter:START-ELEMENT("Styles"). /* Header Style */ hSaxWriter:START-ELEMENT("Style"). hSaxwriter:INSERT-ATTRIBUTE("ss:ID","Header"). hSaxWriter:WRITE-EMPTY-ELEMENT("Font"). hSaxWriter:INSERT-ATTRIBUTE("ss:Bold","1"). hSaxWriter:WRITE-EMPTY-ELEMENT("Alignment"). hSaxWriter:INSERT-ATTRIBUTE("ss:WrapText","1"). hSaxWriter:END-ELEMENT("Style"). /* Bold Sty;e (like header, no wrap) */ hSaxWriter:START-ELEMENT("Style"). hSaxwriter:INSERT-ATTRIBUTE("ss:ID","Bold"). hSaxWriter:WRITE-EMPTY-ELEMENT("Font"). hSaxWriter:INSERT-ATTRIBUTE("ss:Bold","1"). hSaxWriter:END-ELEMENT("Style"). /* Default Style */ hSaxWriter:START-ELEMENT("Style"). hSaxwriter:INSERT-ATTRIBUTE("ss:ID","Default"). hSaxWriter:END-ELEMENT("Style"). /* Date style */ hSaxWriter:START-ELEMENT("Style"). hSaxwriter:INSERT-ATTRIBUTE("ss:ID","Date"). hSaxWriter:WRITE-EMPTY-ELEMENT("NumberFormat"). hSaxWriter:INSERT-ATTRIBUTE("ss:Format","[ENG][$-409]d\-mmm\-yyyy;@"). hSaxWriter:END-ELEMENT("Style"). /*DateTime Style */ hSaxWriter:START-ELEMENT("Style"). hSaxwriter:INSERT-ATTRIBUTE("ss:ID","DateTime"). hSaxWriter:WRITE-EMPTY-ELEMENT("NumberFormat"). hSaxWriter:INSERT-ATTRIBUTE("ss:Format","[ENG][$-409]d\-mmm\-yyyy\ hh:mm;@"). hSaxWriter:END-ELEMENT("Style"). /* Two decimals style */ hSaxWriter:START-ELEMENT("Style"). hSaxwriter:INSERT-ATTRIBUTE("ss:ID","Decimal2"). hSaxWriter:WRITE-EMPTY-ELEMENT("NumberFormat"). hSaxWriter:INSERT-ATTRIBUTE("ss:Format","#,##0.00_);[Red]\(#,##0.00\)"). hSaxWriter:END-ELEMENT("Style"). /* Percent Style with 2 decimals*/ hSaxWriter:START-ELEMENT("Style"). hSaxwriter:INSERT-ATTRIBUTE("ss:ID","Percent2"). hSaxWriter:WRITE-EMPTY-ELEMENT("NumberFormat"). hSaxWriter:INSERT-ATTRIBUTE("ss:Format","0.00%"). hSaxWriter:END-ELEMENT("Style"). /* Logical Style */ hSaxWriter:START-ELEMENT("Style"). hSaxwriter:INSERT-ATTRIBUTE("ss:ID","Logical"). hSaxWriter:WRITE-EMPTY-ELEMENT("NumberFormat"). hSaxWriter:INSERT-ATTRIBUTE("ss:Format","Yes/No"). hSaxWriter:END-ELEMENT("Style"). /* Hyperlink style */ hSaxWriter:START-ELEMENT("Style"). hSaxwriter:INSERT-ATTRIBUTE("ss:ID","Hyperlink"). hSaxWriter:WRITE-EMPTY-ELEMENT("Font"). hSaxWriter:INSERT-ATTRIBUTE("ss:Color","#0000FF"). hSaxWriter:INSERT-ATTRIBUTE("ss:Underline","Single"). hSaxWriter:END-ELEMENT("Style"). FOR EACH tt-Style: hSaxWriter:START-ELEMENT("Style"). hSaxwriter:INSERT-ATTRIBUTE("ss:ID",tt-Style.styleName). FOR EACH tt-StyleElement WHERE tt-StyleElement.styleName = tt-style.styleName: hSaxWriter:WRITE-EMPTY-ELEMENT(tt-StyleElement.elementName). FOR EACH tt-styleElementAttribute WHERE tt-StyleElementAttribute.styleName = tt-Style.StyleName AND tt-StyleElementAttribute.elementName = tt-styleElement.elementName: hSaxWriter:INSERT-ATTRIBUTE("ss:" + tt-StyleElementAttribute.attributeName, tt-styleElementAttribute.attributeValue). END. END. hSaxWriter:END-ELEMENT("Style"). END. hsaxWriter:END-ELEMENT("Styles"). END PROCEDURE. /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME &ENDIF &IF DEFINED(EXCLUDE-MakeDocument) = 0 &THEN &ANALYZE-SUSPEND _UIB-CODE-BLOCK _PROCEDURE MakeDocument Procedure PROCEDURE MakeDocument : /*------------------------------------------------------------------------------ Purpose: Parameters: Notes: ------------------------------------------------------------------------------*/ DEF INPUT PARAMETER TABLE-HANDLE FOR hTempTable. /* source data temp-table */ DEF INPUT PARAMETER createHeader AS LOG NO-UNDO. /* add a header row? */ DEF INPUT PARAMETER workSheetName AS CHAR NO-UNDO. /* The name of the worksheet */ DEF INPUT PARAMETER pFileName AS CHAR NO-UNDO. CREATE SAX-WRITER hSaxWriter. hSaxWriter:ENCODING = "UTF-8". hSaxWriter:FORMATTED = TRUE. hSaxWriter:SET-OUTPUT-DESTINATION("FILE",pFileName). hSaxWriter:START-DOCUMENT(). hsaxWriter:WRITE-PROCESSING-INSTRUCTION("mso-application","progid=~"Excel.Sheet~""). /* Make workbook */ hSaxWriter:START-ELEMENT("Workbook"). hSaxWriter:INSERT-ATTRIBUTE("xmlns","urn:schemas-microsoft-com:office:spreadsheet"). hSaxWriter:INSERT-ATTRIBUTE("xmlns:html","http://www.w3.org/TR/REC-html40"). hSaxWriter:INSERT-ATTRIBUTE("xmlns:o","urn:schemas-microsoft-com:office:office"). hSaxWriter:INSERT-ATTRIBUTE("xmlns:ss","urn:schemas-microsoft-com:office:spreadsheet"). hSaxWriter:INSERT-ATTRIBUTE("xmlns:x","urn:schemas-microsoft-com:office:excel"). RUN createStyles. /* Make worksheet */ hSaxWriter:START-ELEMENT("Worksheet"). hSaxWriter:INSERT-ATTRIBUTE("ss:Name",workSheetName). /*Make the table */ hSaxWriter:START-ELEMENT("Table"). RUN createColumns. RUN createRows(hTopRowTable). IF createHeader THEN RUN createHeader. RUN createRows (hTempTable). hSaxWriter:END-ELEMENT("Table"). hSaxWriter:END-ELEMENT("Worksheet"). hSaxWriter:END-ELEMENT("Workbook"). hSaxWriter:END-DOCUMENT(). DELETE OBJECT hSaxWriter. END PROCEDURE. /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME &ENDIF &IF DEFINED(EXCLUDE-setCellAttrs) = 0 &THEN &ANALYZE-SUSPEND _UIB-CODE-BLOCK _PROCEDURE setCellAttrs Procedure PROCEDURE setCellAttrs : /*------------------------------------------------------------------------------ Purpose: Parameters: Notes: ------------------------------------------------------------------------------*/ DEF INPUT PARAMETER hBuff AS HANDLE NO-UNDO. DEF INPUT PARAMETER i AS INT NO-UNDO. DEF VAR hyperlinkNumber AS INT NO-UNDO. CASE hBuff:BUFFER-FIELD(i):FORMAT: WHEN "xlBold" THEN DO: hSaxWriter:INSERT-ATTRIBUTE("ss:StyleID","Bold"). END. WHEN "xlDefault" THEN DO: hSaxWriter:INSERT-ATTRIBUTE("ss:StyleID","Default"). END. END CASE. hyperLinkNumber = LOOKUP(hBuff:BUFFER-FIELD(i):NAME,hbuff:BUFFER-FIELD("hyperlink_info"):LABEL) NO-ERROR. IF hyperlinkNumber GT 0 AND hyperLinkNumber NE ? THEN DO: IF entry(hyperlinkNumber, hbuff:BUFFER-FIELD("hyperlink_info"):BUFFER-VALUE) NE "" THEN DO: hSaxWriter:INSERT-ATTRIBUTE("ss:HRef", entry(hyperlinkNumber,hbuff:BUFFER-FIELD ("hyperlink_info"):BUFFER-VALUE)). END. ELSE hSaxWriter:INSERT-ATTRIBUTE("ss:StyleID","Default"). END. RETURN. END PROCEDURE. /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME &ENDIF &IF DEFINED(EXCLUDE-setColumnWidth) = 0 &THEN &ANALYZE-SUSPEND _UIB-CODE-BLOCK _PROCEDURE setColumnWidth Procedure PROCEDURE setColumnWidth : /*------------------------------------------------------------------------------ Purpose: Parameters: Notes: ------------------------------------------------------------------------------*/ DEF INPUT PARAMETER p-columnname AS CHAR. DEFINE INPUT PARAMETER p-columnwidth AS INT. FIND tt-columnwidth WHERE tt-columnwidth.columnname = p-columnName NO-ERROR. IF NOT AVAILABLE tt-columnwidth THEN CREATE tt-columnWidth. ASSIGN tt-columnWidth.columnwidth = p-columnWidth tt-columnWidth.columnName = p-columnname . END PROCEDURE. /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME &ENDIF &IF DEFINED(EXCLUDE-setDataAttrs) = 0 &THEN &ANALYZE-SUSPEND _UIB-CODE-BLOCK _PROCEDURE setDataAttrs Procedure PROCEDURE setDataAttrs : /*------------------------------------------------------------------------------ Purpose: Parameters: Notes: ------------------------------------------------------------------------------*/ DEF INPUT PARAMETER hbuff AS HANDLE NO-UNDO. DEF INPUT PARAMETER i AS INT NO-UNDO. DEF VAR hyperlinkNumber AS INT NO-UNDO. DEF VAR testnum AS DEC NO-UNDO. /* Handle the Progress unknown value for any data type */ IF hBuff:BUFFER-FIELD(i):BUFFER-VALUE EQ ? THEN do: hSaxWriter:INSERT-ATTRIBUTE("ss:Type","String"). END. ELSE DO: CASE hBuff:BUFFER-FIELD(i):DATA-TYPE: WHEN "date" THEN do: hSaxWriter:INSERT-ATTRIBUTE("ss:Type","DateTime"). END. WHEN "datetime" THEN DO: hSaxWriter:INSERT-ATTRIBUTE("ss:Type","DateTime"). END. WHEN "datetime-tz" THEN DO: hSaxWriter:INSERT-ATTRIBUTE("ss:Type","DateTime"). END. WHEN "decimal" THEN DO: hSaxWriter:INSERT-ATTRIBUTE("ss:Type","Number"). END. WHEN "Integer" THEN DO: hSaxWriter:INSERT-ATTRIBUTE("ss:Type","Number"). END. WHEN "Int64" THEN DO: hSaxWriter:INSERT-ATTRIBUTE("ss:Type","Number"). END. WHEN "logical" THEN DO: hSaxWriter:INSERT-ATTRIBUTE("ss:Type","Number"). END. OTHERWISE do: /* Check for special formats on strings*/ CASE hBuff:BUFFER-FIELD(i):FORMAT: /* See if the format says change this to a number if possible */ WHEN "xlNumber" THEN DO: testNum = DEC(hBuff:BUFFER-FIELD(i):BUFFER-VALUE) NO-ERROR. IF NOT ERROR-STATUS:ERROR THEN hSaxWriter:INSERT-ATTRIBUTE("ss:Type","Number"). ELSE hSaxWriter:INSERT-ATTRIBUTE("ss:Type","String"). END. OTHERWISE hSaxWriter:INSERT-ATTRIBUTE("ss:Type","String"). END CASE. END. END CASE. END. END PROCEDURE. /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME &ENDIF &IF DEFINED(EXCLUDE-setDataValues) = 0 &THEN &ANALYZE-SUSPEND _UIB-CODE-BLOCK _PROCEDURE setDataValues Procedure PROCEDURE setDataValues : /*------------------------------------------------------------------------------ Purpose: Parameters: Notes: ------------------------------------------------------------------------------*/ DEF INPUT PARAMETER hbuff AS HANDLE NO-UNDO. DEF INPUT PARAMETER i AS INT NO-UNDO. /* Handle the Progress unknown value for any data type */ IF hBuff:BUFFER-FIELD(i):BUFFER-VALUE EQ ? THEN do: hSaxWriter:WRITE-CHARACTERS("?"). END. ELSE DO: CASE hBuff:BUFFER-FIELD(i):DATA-TYPE: WHEN "date" THEN do: hSaxWriter:WRITE-CHARACTERS( ISO-DATE(hBuff:BUFFER-FIELD(i):BUFFER-VALUE)). END. WHEN "datetime" THEN DO: hSaxWriter:WRITE-CHARACTERS( ISO-DATE(hBuff:BUFFER-FIELD(i):BUFFER-VALUE)). END. WHEN "datetime-tz" THEN DO: hSaxWriter:WRITE-CHARACTERS( ISO-DATE(hBuff:BUFFER-FIELD(i):BUFFER-VALUE)). END. WHEN "decimal" THEN DO: hSaxWriter:WRITE-CHARACTERS(string(hBuff:BUFFER-FIELD(i):BUFFER-VALUE)). END. WHEN "Integer" THEN DO: hSaxWriter:WRITE-CHARACTERS( string(hBuff:BUFFER-FIELD(i):BUFFER-VALUE)). END. WHEN "Int64" THEN DO: hSaxWriter:WRITE-CHARACTERS( string(hBuff:BUFFER-FIELD(i):BUFFER-VALUE)). END. WHEN "logical" THEN DO: hSaxWriter:WRITE-CHARACTERS(string(int(hBuff:BUFFER-FIELD(i):BUFFER-VALUE))). END. OTHERWISE do: hSaxWriter:WRITE-CHARACTERS( convUTF-8(string(hBuff:BUFFER-FIELD(i):BUFFER-VALUE))). END. END CASE. END. END PROCEDURE. /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME &ENDIF /* ************************ Function Implementations ***************** */ &IF DEFINED(EXCLUDE-ConvUTF-8) = 0 &THEN &ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION ConvUTF-8 Procedure FUNCTION ConvUTF-8 RETURNS CHARACTER ( INPUT pChar AS CHAR ) : /*------------------------------------------------------------------------------ Purpose: Converts from the current codepage to utf-8 Notes: ------------------------------------------------------------------------------*/ pChar = CODEPAGE-CONVERT(pChar,"UTF-8",SESSION:CPINTERNAL). RETURN pChar. /* Function return value. */ END FUNCTION. /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME &ENDIF