SCI.XLS.RECALL
From Pickwiki
Since Office 2003, Excel has supported so-called XML Spreadsheets, using a schema known as SpreadsheetML - this is a simple approach that has the advantage of creating a single file, in a manageable format. There are a couple of downsides: 1) If you name the file .xml it opens in IE, but if you name it .xls it opens in Excel with a warning that may be alarming. 2) If you are exporting thousands of rows with dozens of columns, the resulting files can get quite large. Still, for modest needs this is an easy approach.
This program takes the path to a "^" delimited file as a parameter, and then dumps the file to an XML spreadsheet suitable for loading into Excel.
If the wiki format messes things up, the latest version can be downloaded from github at https://github.com/ianmcgowan/SCI.BP/blob/master/SCI.XLS.RECALL
***************************************************************************
* Program: SCI.XLS.RECALL
* Author : MCGOWJ01
* Date : 2017-02-10
* Edited :
* Comment: Convert a recall into an excel sheet
***************************************************************************
* LOG DATE BY CHANGE
* ---------- ------------ -------------------------------------------------
* SEE: https://msdn.microsoft.com/en-us/library/aa140066(office.10).aspx
* https://blogs.msdn.microsoft.com/brian_jones/2005/06/27/introduction-to-excel-xml-part-1-creating-a-simple-table/
*
DEBUG=0
S=@SENTENCE
FILE.NAME=FIELD(S,' ',2)
OPENSEQ FILE.NAME TO INPUT.F ELSE STOP 201,FILE.NAME
OUTPUT.FILE.NAME=FILE.NAME:'.xls'
EXECUTE '!rm -f ':OUTPUT.FILE.NAME
EXECUTE '!touch ':OUTPUT.FILE.NAME
OPENSEQ OUTPUT.FILE.NAME TO OUTPUT.F ELSE STOP 'CANNOT OPEN ':OUTPUT.FILE.NAME
OPEN 'RECALLS' TO RECALLS ELSE STOP 201,'RECALLS'
GOSUB GET.FIELD.NAMES
IF DEBUG THEN
PRINT 'FIELD.MAP'
FOR F=1 TO DCOUNT(FIELD.MAP<1>,@VM)
PRINT F'R#2':' ':FIELD.MAP<6,F>'L#20':' ':FIELD.MAP<2,F>'L#35':' ':FIELD.MAP<3,F>
NEXT F
END
CONTROL.CHARS=''
FOR CHARACTER = 127 TO 249
CONTROL.CHARS:=CHAR(CHARACTER)
NEXT CHARACTER
*
GOSUB XLS.HEADER
ROW.COUNT=0
LOOP
READSEQ ROW FROM INPUT.F ELSE EXIT
ROW.COUNT+=1
GOSUB XLS.BODY
REPEAT
GOSUB XLS.TOTALS
GOSUB XLS.FOOTER
RECIP='' ; FROM.USER='' ; CC.USER='' ;* Let the SUBR figure it out
MSG='Please find your report attached'
SUBJECT='REPORT:':FIELD(OUTPUT.FILE.NAME,'/',DCOUNT(OUTPUT.FILE.NAME,'/'))
ATTACH=OUTPUT.FILE.NAME
OPTIONS=''
CALL SCI.MAIL.SUB(RECIP, FROM.USER, CC.USER, MSG, ATTACH, SUBJECT, OPTIONS)
STOP
*
XLS.BODY:
L='<Row>' ; GOSUB WRITE.LINE
CONVERT '^' TO @VM IN ROW
FOR C=1 TO DCOUNT(ROW<1>,@VM)
L=' <Cell>'
CELL=ROW<1,C>
GOSUB URL.ENCODE.CELL
FORMAT=FIELD.MAP<3,C>
CONVERT ',' TO '' IN FORMAT ;* MR2, excel has a hard time with commas in numbers
BEGIN CASE
CASE FORMAT[1,1]='D' AND ICONV(CELL,'D') # '' ;* Date
D=ICONV(CELL,'D')
CELL=OCONV(D,'D4Y'):'-':OCONV(D,'DM'):'-':OCONV(D,'DD')
*CELL:='T00:00:00.000'
L:='<Data ss:Type="DateTime">':CELL:'</Data>'
CASE FORMAT[1,2]='MD' OR FORMAT[1,2]='MR' OR (NUM(CELL) AND CELL#'') ;* Number
CONVERT ',' TO '' IN CELL
IF NUM(CELL) THEN
L:='<Data ss:Type="Number">':CELL:'</Data>'
END ELSE
L:='<Data ss:Type="String">':CELL:'</Data>'
END
CASE 1 ;* String is default type
L:='<Data ss:Type="String">':CELL:'</Data>'
END CASE
L:='</Cell>'
GOSUB WRITE.LINE
NEXT C
L='</Row>'
GOSUB WRITE.LINE
RETURN
*
XLS.TOTALS:
L='<Row>'
GOSUB WRITE.LINE
FOR C=1 TO DCOUNT(FIELD.MAP<1>,@VM)
FORMAT=FIELD.MAP<3,C>
IF FORMAT[1,2]='MD' OR FORMAT[1,2]='MR' THEN
* Number col, add total to bottom row
L=' <Cell ss:Index="':C:'" ss:Formula="=SUM(R[-':ROW.COUNT:']C:R[-1]C)"><Data ss:Type="Number">0</Data></Cell>'
GOSUB WRITE.LINE
END
NEXT C
L='</Row>'
GOSUB WRITE.LINE
RETURN
*
URL.ENCODE.CELL:
* Certain characters not allowed in XML - escape them
CONVERT CONTROL.CHARS TO '' IN CELL ;* Zap unicode/other code pages
SWAP '&' WITH '&' IN CELL
SWAP '<' WITH '<' IN CELL
SWAP '>' WITH '>' IN CELL
CELL=TRIM(CELL);* No benefit to leading or trailing spaces
RETURN
*
XLS.HEADER:
L='<?xml version="1.0"?>'
GOSUB WRITE.LINE
L='<?mso-application progid="Excel.Sheet"?>'
GOSUB WRITE.LINE
L='<Workbook xmlns="urn:schemas-microsoft-com:office:spreadsheet"'
L:=' xmlns:o="urn:schemas-microsoft-com:office:office"'
L:=' xmlns:x="urn:schemas-microsoft-com:office:excel"'
L:=' xmlns:ss="urn:schemas-microsoft-com:office:spreadsheet"'
L:=' xmlns:html="http://www.w3.org/TR/REC-html40">'
GOSUB WRITE.LINE
L=' <Styles>'
GOSUB WRITE.LINE
L=' <Style ss:ID="Default" ss:Name="Normal">'
L:='<Alignment ss:Vertical="Bottom"/>'
L:='<Font ss:FontName="Calibri" x:Family="Swiss" ss:Size="11" ss:Color="#000000"/>'
L:='</Style>'
GOSUB WRITE.LINE
L=' <Style ss:ID="s100" ss:Name="Header">'
L:='<Font ss:FontName="Calibri" x:Family="Swiss" ss:Size="11" ss:Color="#005100" ss:Bold="1"/>'
L:='<Interior ss:Color="#C6EFCE" ss:Pattern="Solid"/>'
L:='</Style>'
GOSUB WRITE.LINE
L=' <Style ss:ID="s101" ss:Name="Number">'
L:='<NumberFormat ss:Format="0.00"/>'
L:='</Style>'
GOSUB WRITE.LINE
L=' <Style ss:ID="s102" ss:Name="Date">'
L:='<NumberFormat ss:Format="Short Date"/>'
L:='</Style>'
GOSUB WRITE.LINE
L=' <Style ss:ID="s103" ss:Name="Integer">'
L:='<NumberFormat ss:Format="0"/>'
L:='</Style>'
GOSUB WRITE.LINE
L=' </Styles>'
GOSUB WRITE.LINE
L=' <Worksheet ss:Name="Sheet1">'
GOSUB WRITE.LINE
L=' <Table>'
GOSUB WRITE.LINE
* Column definitions
FOR C=1 TO DCOUNT(FIELD.MAP<1>,@VM)
FORMAT=FIELD.MAP<3,C>
MASK=FIELD.MAP<5,C>
MASK=MASK[1,LEN(MASK)-1]
IF NOT(NUM(MASK)) THEN MASK=10
BEGIN CASE
CASE FORMAT[1,1]='D' ;* Date
STYLE='s102'
CASE FORMAT[1,2]='MD' OR FORMAT[1,2]='MR' ;* Number
IF FORMAT[3,1]='0' THEN
STYLE='s103'
END ELSE
STYLE='s101'
END
CASE 1 ;* String is default type
STYLE='Default'
END CASE
L=' <Column ss:Index="':C:'" ss:StyleID="':STYLE:'" ss:Width="':MASK*10:'"/>'
GOSUB WRITE.LINE
NEXT C
*
* Now write a header row
*
L='<Row>' ; GOSUB WRITE.LINE
FOR C=1 TO DCOUNT(FIELD.MAP<1>,@VM)
L=' <Cell ss:StyleID="s100">'
*CELL=TRIM(FIELD.MAP<4,C>)
*IF CELL='' THEN CELL=FIELD.MAP<6,C>
CELL=FIELD.MAP<6,C>
GOSUB URL.ENCODE.CELL
L:='<Data ss:Type="String">':CELL:'</Data></Cell>'
GOSUB WRITE.LINE
NEXT C
L='</Row>'
GOSUB WRITE.LINE
RETURN
*
XLS.FOOTER:
L=' </Table>'
GOSUB WRITE.LINE
L=' </Worksheet>'
GOSUB WRITE.LINE
L='</Workbook>'
GOSUB WRITE.LINE
RETURN
*
WRITE.LINE:
*IF DEBUG THEN PRINT L
WRITESEQ L:CHAR(13) APPEND ON OUTPUT.F ELSE STOP 'ERROR WRITING ':FILE.NAME
RETURN
*
GET.FIELD.NAMES:
FIELD.MAP=''
RECALL.NAME=FIELD(FILE.NAME,'/',DCOUNT(FILE.NAME,'/'))
READV R FROM RECALLS, RECALL.NAME, 1 ELSE STOP 'CANNOT READ RECALLS:':RECALL.NAME
DATA.FILE=''
FOR F=1 TO DCOUNT(R,@VM)
L=R<1,F>
IF FIELD(L,' ',1) = 'list' OR FIELD(L,' ',1) = 'sort' THEN
IF DATA.FILE # '' THEN STOP 'CAN ONLY PROCESS ONE list OR sort PER RECALL'
DATA.FILE=FIELD(L,' ',2)
OPEN 'DICT',DATA.FILE TO DICT ELSE STOP 'CANNOT OPEN DICT ':DATA.FILE
END
IF DATA.FILE # '' THEN
FOR WC=1 TO DCOUNT(L,' ')
* list LS.MASTER FIELD1 FIELD2 ETC.. Skip the first two
ATB=FIELD(L,' ',WC)
IF ATB='list' OR ATB='sort' THEN CONTINUE
IF ATB=DATA.FILE THEN CONTINUE
IF ATB='TO' THEN
* Stop when we get to the TO DELIM etc...
RETURN
END
READ DICT.REC FROM DICT, ATB THEN
TYPE=DICT.REC<1>
CORR=DICT.REC<2>
CONV=DICT.REC<3>
HEAD=DICT.REC<4>
MASK=DICT.REC<5>
N=DCOUNT(FIELD.MAP<1>,@VM)+1 ;* Always nervous of NULL with <1,-1>
FIELD.MAP<1,N>=TYPE
FIELD.MAP<2,N>=CORR
FIELD.MAP<3,N>=CONV
FIELD.MAP<4,N>=HEAD
FIELD.MAP<5,N>=MASK
FIELD.MAP<6,N>=ATB
END ELSE
IF ATB # 'BY' AND ATB # 'WITH' THEN
PRINT 'ATB ':ATB:' NOT FOUND IN DICT ':DATA.FILE
END
END
NEXT WC
END
NEXT F
RETURN
