2003-06-09 17:34

'QXLS.INC by Doctor Electron  Copyright 2002,2003 Global Services
'Last Modified: June 9, 2003
'These functions read all sheets in multiple Excel .xls files.

'R value masks
     CONST xRKby100&=&H1   '0=value not changed
     CONST xRKInteger&=&H2 '0=floating-point
     CONST xRKEncoded&=&HFFFFFFFC

'Error Codes
'CONST xNULL=0
'CONST xDIVby0=&H7
'CONST xVALUE=&HF
'CONST xRK=&H17
'CONST xNAME=&H1D
'CONST xNUM=&H24
'CONST xNA=&H2A

'Record Codes-WorkBook
     CONST xBOF??=&H809
     CONST xEOF??=&HA
     CONST xFILEPASS??=&H2F
     CONST xPASSWORD??=&H13
     CONST xBOUNDSHEET??=&H85
     CONST xSST??=&HFC
     CONST xCONTINUE??=&H3C
'Record Codes-WorkSheets
     CONST xINDEX??=&H20B
     CONST xDIMENSIONS??=&H200
     CONST xROW??=&H208
     CONST xDBCELL??=&HD7
     CONST xWINDOW2??=&H23E
     CONST xSELECTION??=&H1D
'Record Codes-Cells
     CONST xARRAY??=&H221
     CONST xBLANK??=&H201
     CONST xBOOLERR??=&H205
     CONST xFORMULA??=&H206
     CONST xLABEL??=&H204
     CONST xLABELSST??=&HFD
     CONST xNUMBER??=&H203
     CONST xMULBLANK??=&HBE
     CONST xMULRK??=&HBD
     CONST xRK??=&H27E
     CONST xRSTRING??=&HD6
     CONST xSHRFMLA??=&HBC
     CONST xSTRING??=&H207

'P table columns
     CONST pOFFSET&=0&
     CONST pSHEET&=1&
     CONST pDIMENSIONS&=2&
     CONST pminROW&=3&
     CONST pmaxROW&=4&
     CONST pminCOL&=5&
     CONST pmaxCOL&=6&
     CONST pLENGTH&=7&
     CONST NumVars&=7&

'Program 0-based dimension constants
     CONST MaxBooks&=7&
     CONST MaxSheets&=15&
     CONST MaxBytes&=4095&
     CONST MaxSST&=255&

     DECLARE FUNCTION xlsOPEN AS LONG
     DECLARE FUNCTION xlsREAD(s AS LONG, row AS LONG, col AS LONG) AS STRING
     DECLARE FUNCTION xlsSHEETNAME(s AS LONG) AS STRING
     DECLARE FUNCTION xlsMINROW(s AS LONG) AS LONG
     DECLARE FUNCTION xlsMAXROW(s AS LONG) AS LONG
     DECLARE FUNCTION xlsMINCOL(s AS LONG) AS LONG
     DECLARE FUNCTION xlsMAXCOL(s AS LONG) AS LONG
     DECLARE FUNCTION xlsSHEETLENGTH(s AS LONG) AS LONG
     DECLARE FUNCTION xlsNUMBERSHEETS AS LONG
     DECLARE FUNCTION xlsCLOSE AS LONG
     DECLARE FUNCTION B2W(index AS LONG) AS WORD
     DECLARE FUNCTION RK2str AS STRING
     DECLARE FUNCTION StrRecLen AS LONG
     DECLARE FUNCTION xlsSAVE(file AS STRING) AS LONG
     DECLARE FUNCTION xlsWRITE(s AS LONG, row AS LONG, col AS LONG, value AS STRING) AS LONG

     DECLARE SUB ReadOLEFile
     DECLARE SUB GetRecord
     DECLARE SUB GetData
     DECLARE SUB ClearBookData
'Declare SUB Uncorrupt
'Declare SUB RemoveTrash
     DECLARE SUB ShiftBook(PTR AS LONG, nbytes AS LONG)
     DECLARE SUB SheetPointers(s AS LONG, nbytes AS LONG)
     DECLARE SUB ChangeValue(PTR AS LONG, blen AS LONG, nbytes AS LONG)
     DECLARE SUB FillFile(value AS LONG, amt AS LONG)
     DECLARE SUB PrintSheetNames
     DECLARE SUB PrintSSTRecords

'Stratch variables
     DIM xB1 AS BYTE, xB2 AS BYTE
     DIM buf(MaxBytes&) AS BYTE
     DIM xCode AS WORD, xLength AS WORD, sCode AS WORD, sLength AS WORD, xFinish AS WORD
     DIM xType AS LONG, xFormat AS WORD, xIntegrity AS WORD
     DIM i AS LONG, j AS LONG, k AS LONG, xEnd AS LONG, xTmp AS LONG
     DIM xPosition AS LONG, xNext AS LONG, wPosition AS LONG
     DIM ptrINDEX AS LONG, ptrINDEXEnd AS LONG
     DIM ptrDB AS LONG, ptrDBOffset AS LONG, ptrROW AS LONG, ptrData AS LONG
     DIM RK AS LONG, xInt AS LONG, xUnicode AS LONG
     DIM xIEEE AS DOUBLE
     DIM s$ AS STRING, sERR AS STRING
     DIM F AS QFILESTREAM, F2 AS QFILESTREAM
'WorkBook specific
     DIM b AS LONG                 'This is the workbook index
     DIM M(MaxBooks&) AS QMEMORYSTREAM
     DIM FileSpec(MaxBooks&) AS STRING
     DIM P(MaxBooks&,MaxSheets&,NumVars&) AS LONG
     DIM SST(MaxBooks&,MaxSST&,2) AS LONG  'unique string block data
     DIM tSST(MaxBooks&) AS LONG    'n unique strings
     DIM nSST(MaxBooks&) AS WORD    'n blocks of strings in SST
     DIM nSheets(MaxBooks&) AS WORD 'n sheets according to BOUNDSHEET records
     DIM nSR(MaxBooks&) AS WORD     'n sheets read
     DIM SheetName(MaxBooks&,MaxSheets&) AS STRING

'''''Main Routines
     FUNCTION xlsOPEN
      Result=-1&: xFinish=0??: sERR=""
      IF (b<0&) OR (b>MaxBooks&) THEN sERR="Book out of range": EXIT FUNCTION
      ClearBookData
      IF FILEEXISTS(FileSpec(b))<=0& THEN sERR="File not found": EXIT FUNCTION
      ReadOLEFile
      IF sERR<>"" THEN GOTO OpenFail
      M(b).Position=0&
FindBOF:
'GetRecord
      xCode=M(b).ReadNum(2&): xLength=M(b).ReadNum(2&): xNext=M(b).Position+xLength
      IF xCode=xBOF?? THEN
       xNext=M(b).Position-4&
       IF xNext>0& THEN CALL ShiftBook(0&,-xNext): xNext=0&
       P(b,0&,0&)=0&: GOTO NextParse
      ELSE
       M(b).Position=M(b).Position+&H3C
       IF M(b).Position<M(b).Size THEN GOTO FindBOF
       sERR="BOF not found": GOTO OpenFail
      END IF
NextOpen:
      xPosition=M(b).Position  ': GetRecord
      xCode=M(b).ReadNum(2&): xLength=M(b).ReadNum(2&): xNext=M(b).Position+xLength
      SELECT CASE xCode
      CASE xBOF??
       GetData
       IF B2W(0&)<>&H600 THEN sERR="Not BIFF8 file": GOTO OpenFail
       IF B2W(2&)<>5?? THEN
        IF nSR(b)<MaxSheets& THEN INC(nSR(b)) ELSE sERR="Too many sheets": GOTO OpenFail
        IF xPosition<>P(b,nSR(b),0&) THEN sERR="File format read error": GOTO OpenFail
       END IF
       P(b,nSR(b),pOFFSET&)=xPosition
      CASE xEOF??
       P(b,nSR(b),pLENGTH&)=M(b).Position-P(b,nSR(b),pOFFSET&)
       IF nSR(b)=nSheets(b) THEN xFinish=1?? 'accounted for all BOUNDSHEETs
' WorkBook Globals
      CASE xFILEPASS??
       IF xLength<>0?? THEN sERR="File password required": GOTO OpenFail
      CASE xPASSWORD??
       IF xLength<>2?? THEN sERR="Password required": GOTO OpenFail
      CASE xBOUNDSHEET??
       IF nSheets(b)<MaxSheets& THEN INC(nSheets(b)) ELSE sERR="Too many sheets": GOTO OpenFail
       P(b,nSheets(b),pSHEET&)=xPosition: GetData
       MEMCPY(VARPTR(P(b,nSheets(b),pOFFSET&)),VARPTR(buf(0&)),4&)
       k=buf(6&)+(256& * buf(7&))+7&: s$=""
       FOR i=8& TO k: s$=s$+CHR$(buf(i)): NEXT i
       SheetName(b,nSheets(b))=s$
      CASE xSST??
       IF SST(b,0&,0&)<>0& THEN sERR="Multiple SST records": GOTO OpenFail
       SST(b,0&,0&)=xPosition+12&
       M(b).Position=M(b).Position+4&: tSST(b)=M(b).ReadNum(4&) 'Total SST strings
       nSST(b)=0&: j=0&: k=0&
       IF tSST(b)=0& THEN GOTO CheckSSTtotal
CountStrings:
'  xTmp=StrRecLen
       sLength=M(b).ReadNum(2&): xTmp=sLength
       sCode=0??: sCode=M(b).ReadNum(1&)
       IF (sCode AND 1)>0?? THEN sLength=2??*sLength: xTmp=sLength 'String not compressed
       IF (sCode AND 8)>0?? THEN xTmp=M(b).ReadNum(2&): xTmp=sLength+4&*xTmp 'RichString
       IF (sCode AND 4)>0?? THEN i=M(b).ReadNum(4&): xTmp=xTmp+i  'Far East
'
       M(b).Position=M(b).Position+xTmp: INC(k)
       IF j+k>=tSST(b) THEN GOTO EndofBlock
       IF M(b).Position<xNext THEN GOTO CountStrings
EndofBlock:
       xTmp=0&
  'Check if some lamer wrote a string across records.  Thus...
       IF M(b).Position>xNext THEN xTmp=M(b).Position-xNext+1
       SST(b,nSST(b),1&)=k: SST(b,nSST(b),2&)=M(b).Position: j=j+k: k=0&
       IF j>=tSST(b) THEN GOTO CheckSSTTotal
       IF M(b).Position>P(b,1&,0&) THEN GOTO CheckSSTTotal
       M(b).Position=xNext ': GetRecord
       xCode=M(b).ReadNum(2&): xLength=M(b).ReadNum(2&): xNext=M(b).Position+xLength
       IF xCode=xCONTINUE?? THEN
        IF nSST(b)=MaxSST& THEN sERR="MaxSST& too small": GOTO OpenFail
        INC(nSST(b)): M(b).Position=M(b).Position+xTmp  'ptr to 1st in record
        SST(b,nSST(b),0&)=M(b).Position: GOTO CountStrings
       END IF
CheckSSTTotal:
       IF j<>tSST(b) THEN sERR="SST total mismatch "+STR$(j)+" "+STR$(tSST(b))+" at "+HEX$(M(b).Position): GOTO OpenFail
       IF xIntegrity=0& THEN xNext=P(b,1&,pOFFSET&)-4& '->next EOF
' WorkSheet Data
      CASE xDIMENSIONS??
       P(b,nSR(b),pDIMENSIONS&)=xPosition
       P(b,nSR(b),pminROW&)=M(b).ReadNum(4&): P(b,nSR(b),pmaxROW&)=M(b).ReadNum(4&)
       P(b,nSR(b),pminCOL&)=M(b).ReadNum(2&): P(b,nSR(b),pmaxCOL&)=M(b).ReadNum(2&)
       IF xIntegrity=1& THEN GOTO NextParse
       IF nSR(b)<nSheets(b) THEN xNext=P(b,nSR(b)+1&,pOFFSET&)-4&: GOTO NextParse 'Next BOF-4
       i=P(b,0&,1&)
       IF (i>4096&) AND (i>M(b).Position) THEN xNext=P(b,0&,1&)-4&  'BIFF8 length-4
      END SELECT
NextParse:
      M(b).Position=xNext
      IF xFinish=1?? THEN GOTO OpenDone
      IF M(b).Position<(M(b).Size-4&) THEN GOTO NextOpen
      sERR="Unexpected end of file"
OpenFail:
'ClearBookData
      M(b).CLOSE: EXIT FUNCTION
OpenDone:
      Result=nSR(b)
     END FUNCTION

     FUNCTION xlsSAVE(file AS STRING) AS LONG
      DIM FAT(4&) AS LONG
      Result=-1&: sERR=""
      IF FILEEXISTS(file)<=0& THEN F.OPEN(file,fmCreate) ELSE F.OPEN(file,2&)
      IF FILEEXISTS("qxls.dat")<=0& THEN ExtractResource(Resource(1&),"qxls.dat"):DOEVENTS
      F2.OPEN("qxls.dat",0&)
      M(b).Position=0&: F.Position=0&
      F.CopyFrom(F2,80&): FillFile(-1&,&H200) 'OLE header
      FAT(0&)=P(b,0&,1&)  'file length
      FOR i=0& TO FAT(0&)-1& STEP 8&
       xiEEE=M(b).ReadNum(8&):F.WriteNum(xiEEE,8&): NEXT i
       IF FAT(0&)>&H1000 THEN CALL FillFile(0&,&H200) ELSE CALL FillFile(0&,&H1000)
       FAT(1&)=F.Position: i=1&: xPosition=(F.Position-&H200)\&H200 'ptr to FAT
WriteFATentry:
       IF i<xPosition THEN F.WriteNum(i,4&): INC(i): GOTO WriteFATentry
       F.WriteNum(-2&,4&)
       j=(F.Position-FAT(1&))\&H200+1& '# of FAT sectors
       j=j+(j+2&)\128&
       FOR i=1& TO j: F.WriteNum(-3&,4&): NEXT i
CheckFATCount:
       k=(F.Position-FAT(1&))\&H200+1&
       IF k>j THEN F.WriteNum(-3&,4&): xTmp=F.Position
       F.WriteNum(-2&,4&): FillFile(-1&,&H200)
       FAT(4&)=(F.Position-FAT(1&))\&H200  'final update of # FAT sectors
       IF FAT(4&)>k THEN F.Position=xTmp: j=k-1&: GOTO CheckFATCount
       xInt=(F.Position-&H200)\&H200     'ptr to DIR
       xTmp=F.Position: F2.Position=&H50
       F.CopyFrom(F2,512&) 'ole directory
       IF FAT(0&)<&H1000 THEN i=&H1000 ELSE i=FAT(0&)
       F.Position=xTmp+&HF8: F.WriteNum(i,4&) 'length
       F.Position=&H2C: F.WriteNum(FAT(4&),4&) 'put # of FAT sectors
       F.Position=&H30: F.WriteNum(xInt,4&)   'put DIR ptr
       F.Position=&H4C: i=xPosition: xNext=&H200
WriteFATindex:
       F.WriteNum(i,4&): INC(i)
       IF F.Position<>xNext THEN GOTO FATindexDone
       IF F.Position=&H200 THEN
        F.Position=&H44: F.WriteNum(xInt+1&,4&)
        F.Position=(xInt+2&)*&H200: xNext=F.Position+&H1FC
       ELSE
        j=(F.Position+4&)\&H200-1&: F.WriteNum(j,4&): xNext=F.Position+&H1FC
       END IF
FATindexDone:
       IF i<xInt THEN GOTO WriteFATindex
       FillFile(-1&,&H200)
       IF FAT(4&)>109& THEN i=(FAT(4&)-109&)\128&+1&: F.Position=&H48: F.WriteNum(i,4&)
       Result=F.Size
       F.CLOSE: F2.CLOSE
      END FUNCTION

      FUNCTION xlsREAD(s AS LONG, row AS LONG, col AS LONG) AS STRING
       DIM r AS WORD, c AS WORD, strindex AS WORD
       Result="": sERR=""
       IF (b>MaxBooks&) OR (s>nSR(b)) THEN sERR="Book or sheet index too big": EXIT FUNCTION
       IF (row<P(b,s,pminROW&)) OR (row>=P(b,s,pmaxROW&)) THEN sERR="Row out of bounds": EXIT FUNCTION
       IF (col<0&) OR (col>255&) THEN sERR="Col out of bounds": EXIT FUNCTION
       M(b).Position=P(b,s,pOFFSET&)+20&     'index record
       xEnd=P(b,s,pOFFSET&)+P(b,s,pLENGTH&)  'end of sheet
'Find row block
'GetRecord
GetIndexRecord:
       xCode=M(b).ReadNum(2&): xLength=M(b).ReadNum(2&): xNext=M(b).Position+xLength
       ptrINDEXEnd=xNext
       IF xCode=xINDEX?? THEN GOTO CheckIndex
       M(b).Position=xNext
       IF xNext<xEnd THEN GOTO GetIndexRecord ELSE sERR="Index not found": EXIT FUNCTION '&H208
CheckIndex:
       i=M(b).Readnum(4&)
       IF i<>0& THEN sERR="Bad Index record format": EXIT FUNCTION
       i=M(b).Readnum(4&)
       IF i<>P(b,s,pminROW&) THEN sERR="Index and Dimensions disagree": EXIT FUNCTION
       j=M(b).Readnum(4&)
       IF j<>P(b,s,pmaxROW&) THEN sERR="Index and Dimensions disagree": EXIT FUNCTION
       j=4& * ((row-i)\32&)+4&
       IF j+12&>xLength THEN sERR="Index record too short": EXIT FUNCTION
       ptrINDEX=M(b).Position+j: M(b).Position=ptrINDEX: i=M(b).ReadNum(4&)
       IF i<0& THEN sERR="Neg index pointer": EXIT FUNCTION
       IF i>xEnd THEN sERR="Bad index pointer": EXIT FUNCTION
       M(b).Position=i: xEnd=i
'GetRecord
       xCode=M(b).ReadNum(2&): xLength=M(b).ReadNum(2&): xNext=M(b).Position+xLength
       IF xCode<>xDBCELL?? THEN sERR="DBCell not found": EXIT FUNCTION
       ptrDBOffset=M(b).Position: xTmp=xNext: GetData
       MEMCPY(VARPTR(i),VARPTR(buf(0&)),4&) 'neg offset to first cell data record
       j=xEnd-i+20&: k=0&: i=0&: M(b).Position=j-20&
GetRowRecord:
       ptrROW=M(b).Position
'GetRecord
       xCode=M(b).ReadNum(2&): xLength=M(b).ReadNum(2&): xNext=M(b).Position+xLength
       IF xCode<>xROW?? THEN sERR="Row record not found": EXIT FUNCTION
       k=k+buf(2&*i+4&)+256& * buf(2&*i+5&): r=M(b).ReadNum(4&)
       IF r<row THEN M(b).Position=xNext: INC(i): GOTO GetRowRecord
       ptrDB=xEnd+10&+2&*i
       IF ptrDB>=xTmp THEN ptrDB=0&
       IF r>row THEN sERR="Row not defined": EXIT FUNCTION
       i=j+k: M(b).Position=i: xPosition=i
       IF (i<ptrROW) OR (i>xEnd) THEN sERR="No cell record": EXIT FUNCTION
NextRead:
       xPosition=M(b).Position
'GetRecord
       xCode=M(b).ReadNum(2&): xLength=M(b).ReadNum(2&): xNext=M(b).Position+xLength
       SELECT CASE xCODE
       CASE xSTRING??, xARRAY??, xSHRFMLA??, &H4BC, xCONTINUE??
        GOTO KeepMoving
       END SELECT
       GetData: r=buf(0&)+256&*buf(1&)
       IF r<>row THEN sERR="Col not found/defined": EXIT FUNCTION
       c=buf(2&)+256&*buf(3&)
       IF c>col THEN EXIT FUNCTION  'columns to left were blank/not defined
       IF (c<col) AND (xCode<>xMULRK??) THEN GOTO KeepMoving
       xFormat=buf(4&)+256&*buf(5&): wPosition=xPosition
CellType:
       SELECT CASE xCode
       CASE xLABELSST??
        strindex=buf(6&)+256&*buf(7&): k=0&: i=0&
FindSSTRecord:
        j=k: k=k+SST(b,i,1&)
        IF strindex<k THEN GOTO FindString
        IF i<nSST(b) THEN INC(i): GOTO FindSSTRecord
        sERR="Index>no. strings": EXIT FUNCTION
FindString:
        M(b).Position=SST(b,i,0&): xNext=SST(b,i,2&)
SSTString:
'  xTmp=StrRecLen
        sLength=M(b).ReadNum(2&): xTmp=sLength
        sCode=0&: sCode=M(b).ReadNum(1&)
        IF (sCode AND 1??)>0& THEN sLength=2??*sLength: xTmp=sLength 'String not compressed
        IF (sCode AND 8??)>0& THEN xTmp=M(b).ReadNum(2&): xTmp=sLength+4&*xTmp 'RichString
        IF (sCode AND 4??)>0& THEN i=M(b).ReadNum(4&): xTmp=xTmp+i  'Far East
'
        IF j<>strindex THEN GOTO NextSSTEntry
GetUnicodeNow:
        xUnicode=M(b).Position+M(b).Pointer: s$=""
        FOR i=1& TO sLength
  'Check if string written across a CONTINUE record
         IF M(b).Position=xNext THEN M(b).Position=M(b).Position+5
         xB1=M(b).ReadNum(1&)
  'for 16-bit char and NOT (Far East OR Rich Text), get odd bytes only
         IF sCode=1?? THEN
          xB2=M(b).ReadNum(1&): INC(i)
          SELECT CASE xB2
          CASE 4? 'RUSSIAN
           IF xB1=1? THEN j=167& ELSE j=176&
           IF xB1=81? THEN j=103&
           xB1=xB1+j
          END SELECT
         END IF
         s$=s$+CHR$(xB1)
        NEXT i
        Result=s$: xType=-1&: EXIT FUNCTION
NextSSTEntry:
        INC(j): M(b).Position=M(b).Position+xTmp
        IF M(b).Position>P(b,1&,pOFFSET&) THEN sERR="SST read error": EXIT FUNCTION
        GOTO SSTString
       CASE xRK??, &H7E
        MEMCPY(VARPTR(RK),VARPTR(buf(6&)),4&)
        Result=RK2str: EXIT FUNCTION
       CASE xNUMBER??
xIEEEnumber:
        MEMCPY(VARPTR(xIEEE),VARPTR(buf(6&)),8&)
        Result=STR$(xIEEE): xType=4&: EXIT FUNCTION
       CASE xMULRK??
        IF c>col THEN GOTO KeepMoving
        i=6&  'first RK in buf
NextMULRK:
        IF (c<col) AND (i+6<xLength) THEN INC(c): i=i+6&: GOTO NextMULRK
        IF c=col THEN
         MEMCPY(VARPTR(RK),VARPTR(buf(i)),4&): ptrData=xPosition+i+4&
         Result=RK2str: EXIT FUNCTION
        END IF
       CASE xBLANK??
        sERR="#BLANK": EXIT FUNCTION
       CASE xLABEL??
        M(b).Position=xPosition+10&: xTmp=StrRecLen: GOTO GetUnicodeNow
       CASE xBOOLERR??
        sERR="#BOOLERR": EXIT FUNCTION
       CASE xFORMULA??, &H6, &H406
        xTmp=buf(12&)+256&*buf(13&): sERR="#FORMULA"
        IF (buf(6&)=0&) AND (xTmp=&HFFFF) THEN
         M(b).Position=xNext  'Return value in next record
'    GetRecord
         xCode=M(b).ReadNum(2&): xLength=M(b).ReadNum(2&): xNext=M(b).Position+xLength
         GetData
         SELECT CASE xCODE
         CASE xARRAY??, xSHRFMLA??, &H4BC
          M(b).Position=xNext ': GetRecord
          xCode=M(b).ReadNum(2&): xLength=M(b).ReadNum(2&): xNext=M(b).Position+xLength
          GetData: GOTO CellType
         END SELECT
         GOTO CellType
        END IF
        IF (buf(6&)=1?) AND (xTmp=&HFFFF) THEN Result=STR$(buf(8&)): xType=2&: EXIT FUNCTION
        GOTO xIEEEnumber
       CASE xMULBLANK??
       CASE xSTRING??
        sLength=buf(0&)+256&*buf(1&): s$=""
        FOR i=1& TO sLength: s$=s$+CHR$(buf(i+2&)): NEXT i
        Result=s$: xType=-1&: EXIT FUNCTION
       CASE xWINDOW2??: EXIT FUNCTION
       CASE xSELECTION??: EXIT FUNCTION
       CASE xDBCELL??: sERR="Cell not found": EXIT FUNCTION
       CASE xRSTRING??: sERR="#RSTRING obsolete in BIFF8": EXIT FUNCTION
       CASE ELSE
        sERR="#"+RIGHT$(HEX$(xCode),4&)+" unexpected record code": EXIT FUNCTION
       END SELECT
KeepMoving:
       M(b).Position=xNext
       IF M(b).Position<=xEnd-4& THEN GOTO NextRead
      END FUNCTION

      FUNCTION xlsWRITE(s AS LONG, row AS LONG, col AS LONG, value AS STRING) AS LONG
       DIM wr AS LONG, wc AS LONG, ws AS LONG, wInt AS LONG
       DIM wType AS LONG, wLength AS WORD
       DIM xSingle AS SINGLE
       DIM r$ AS STRING
       Result=-1&: sERR=""
       IF row>P(b,s,pMaxROW&) THEN sERR="Row not found": EXIT FUNCTION
       wr=row: wc=col: ws=s: wType=-1&: wLength=LEN(value)
       IF wLength=0 THEN wType=-2&: GOTO MakeRecord  'null string->BLANK
       FOR i=1& TO wLength: s$=MID$(value,i,1&)
        IF (s$>"9") OR (s$<"-") OR (s$="\") THEN GOTO MakeRecord
       NEXT i
       s$=value: i=TALLY(s$,".")
       IF i>1& THEN GOTO MakeRecord
       j=TALLY(s$,"-")
       IF j>1& THEN GOTO MakeRecord
       IF (j>0&) AND (LEFT$(s$,1&)<>"-") THEN GOTO MakeRecord '"-" not first char
       wType=4&: xIEEE=VAL(s$)
       IF (wlength-i-j)>6& THEN GOTO MakeRecord
       IF (xIEEE>536870911.0#) OR (xIEEE<-536870912.0#) THEN GOTO NotInteger
       IF i=0& THEN wInt=INT(xIEEE): wType=2&: GOTO MakeRecord
       IF INSTR(1&,s$,".")<wLength-2& THEN GOTO NotInteger
       IF (xIEEE>5368709.11#) OR (xIEEE<-5368709.12#) THEN GOTO NotInteger
       wInt=INT(xIEEE*100#): wType=3&: GOTO MakeRecord 'x 100

NotInteger:
       IF (xIEEE<-(1.5E-45)) OR (xIEEE>(3.4E+38)) THEN GOTO MakeRecord
       xSingle=xIEEE
       IF (xSingle AND &HC0000000)=0& THEN wType=0&

MakeRecord:
'Check if record already there
       ptrINDEXEnd=0&: ptrINDEX=0&: ptrDBOffset=0&: ptrROW=0&: ptrDB=0&: ptrData=0&: wPosition=0&
       r$=xlsREAD(ws, wr, wc)  'if record exists, xPosition to xNext-1 is field
       IF (r$="") AND (LEFT$(sERR,1&)<>"#") THEN xLength=0 ELSE xLength=xLength+4
       MEMSET(VARPTR(buf(0&)),0&,4&)
       buf(4&)=wr MOD 256&: buf(5&)=wr\256&: buf(6&)=wc MOD 256&: buf(7&)=wc\256&
       IF xFormat=0& THEN xFormat=&HF
       buf(8&)=xFormat MOD 256&: buf(9&)=xFormat\256&
       SELECT CASE wType
       CASE -2&: buf(0&)=1?: buf(1&)=2?: buf(2&)=6?
       CASE -1&: buf(0&)=4?: buf(1&)=2?
        buf(10&)=wLength MOD 256&: buf(11&)=wLength\256&: buf(12&)=0?
        buf(2&)=(9&+wLength) MOD 256&: buf(3&)=(9&+wLength)\256&
        FOR i=1& TO wLength: buf(12&+i)=ASC(MID$(value,i,1&)): NEXT i
       CASE 0&, 1&, 2&, 3&: buf(0&)=xRK??: buf(1&)=2?: buf(2&)=10?
        IF wType=1& THEN xSingle=100.0!*xSingle
        IF (wType AND 2&)>0& THEN RK=wInt SHL 2& ELSE MEMCPY(VARPTR(RK),VARPTR(xIEEE)+4&,4&)
        RK=(RK AND xRKEncoded&) OR wType
        MEMCPY(VARPTR(buf(10&)),VARPTR(RK),4&)
       CASE 4&: buf(0&)=xNUMBER??: buf(1&)=2?: buf(2&)=14?: MEMCPY(VARPTR(buf(10&)),VARPTR(xIEEE),8&)
       END SELECT
       wLength=4??+buf(2&)+256??*buf(3&)
       wInt=wLength-xLength
       IF wInt=0 THEN GOTO xPutNew
       IF xCode=xMULRK?? THEN M(b).Position=ptrData: M(b).WriteNum(RK,4&): GOTO xWriteDone
       SELECT CASE sERR
       CASE "Row not defined","Col out of bounds": EXIT FUNCTION
       CASE ELSE: wPosition=xPosition
       END SELECT

'Update column data
       IF wc<P(b,ws,pminCOL&) THEN
        P(b,ws,pminCOL&)=wc: xTmp=P(b,ws,pDIMENSIONS&)+12&
        M(b).Position=xTmp: M(b).WriteNum(wc,2&)
       END IF
       IF wc>P(b,ws,pmaxCOL&)-1& THEN
        P(b,ws,pmaxCOL&)=wc+1&: xTmp=P(b,ws,pDIMENSIONS&)+14&
        M(b).Position=xTmp: M(b).WriteNum(wc+1&,2&)
       END IF
       IF ptrROW=0& THEN GOTO FileLength
       M(b).Position=ptrROW+6&: sCode=M(b).ReadNum(2&)
       IF wc<sCode THEN M(b).Position=ptrROW+6&: M(b).WriteNum(wc,2&)
       M(b).Position=ptrROW+8&: sCode=M(b).ReadNum(2&)
       IF wc>=sCode THEN M(b).Position=ptrROW+8&: M(b).WriteNum(wc+1&,2&)

FileLength:
       P(b,0&,1&)=P(b,0&,1&)+wInt
       ChangeValue(P(b,ws,pOFFSET&)+36&,4&,wInt) 'change ptr needed by Excel
UpdateINDEX:
       ChangeValue(ptrINDEX,4&,wInt): ptrINDEX=ptrINDEX+4&
       IF ptrINDEX<ptrINDEXEnd THEN GOTO UpdateINDEX
       SheetPointers(ws,wInt)
       ChangeValue(ptrDBOffset,4&,wInt)
       IF ptrDB>0& THEN ChangeValue(ptrDB,2&,wInt)

       IF wInt>0& THEN ShiftBook(wPosition,wInt) ELSE ShiftBook(wPosition+wLength,wInt)
xPutNew:
       MEMCPY(wPosition+M(b).Pointer,VARPTR(buf(0&)),wLength)
xWriteDone:
       IF wLength>0& THEN sERR=""
       Result=wLength
      END FUNCTION

      SUB SheetPointers(s AS LONG, nbytes AS LONG)
       i=s+1&: j=nbytes
CheckSheetNumber:
       IF i>nSR(b) THEN EXIT SUB
       ChangeValue(P(b,i,pSHEET&)+4&,4&,j)
       M(b).Position=P(b,i,pOFFSET&)+20&
'GetRecord
       xCode=M(b).ReadNum(2&): xLength=M(b).ReadNum(2&): xNext=M(b).Position+xLength
       k=P(b,i,pOFFSET&)+36&
UpdateINDEX2:
       ChangeValue(k,4&,j): k=k+4&
       IF k<xNext THEN GOTO UpdateINDEX2
       P(b,i,pOFFSET&)=P(b,i,pOFFSET&)+j: P(b,i,pDIMENSIONS&)=P(b,i,pDIMENSIONS&)+j
       INC(i): GOTO CheckSheetNumber
      END SUB

      SUB ChangeValue(PTR AS LONG, blen AS LONG, nbytes AS LONG)
       M(b).Position=PTR: xTmp=M(b).ReadNum(blen)
       xTmp=xTmp+nbytes
       M(b).Position=PTR: M(b).WriteNum(xTmp,blen)
      END SUB

      FUNCTION xlsSHEETNAME(s AS LONG) AS STRING
       Result=SheetName(b,s)
      END FUNCTION

      FUNCTION xlsMINROW(s AS LONG) AS LONG
       Result=P(b,s,pminROW&)
      END FUNCTION

      FUNCTION xlsMAXROW(s AS LONG) AS LONG
       Result=P(b,s,pmaxROW&)-1&
      END FUNCTION

      FUNCTION xlsMINCOL(s AS LONG) AS LONG
       Result=P(b,s,pminCOL&)
      END FUNCTION

      FUNCTION xlsMAXCOL(s AS LONG) AS LONG
       Result=P(b,s,pmaxCOL&)-1&
      END FUNCTION

      FUNCTION xlsSHEETLENGTH(s AS LONG) AS LONG
       Result=P(b,s,pLENGTH&)
      END FUNCTION

      FUNCTION xlsNUMBERSHEETS
       Result=nSR(b)
      END FUNCTION

      FUNCTION xlsCLOSE
       Result=-1&
       IF (b<0&) OR (b>MaxBooks&) THEN EXIT FUNCTION
       M(b).CLOSE: ClearBookData: Result=b
      END FUNCTION

'''''Supporting routines
      SUB GetRecord
       xCode=M(b).ReadNum(2&): xLength=M(b).ReadNum(2&): xNext=M(b).Position+xLength
      END SUB

      SUB GetData
       DIM kmax AS WORD
       IF xLength=0?? THEN EXIT SUB
       kmax=MaxBytes&
       IF kmax>xLength-1?? THEN kmax=xLength-1??
       FOR i=0& TO kmax: buf(i)=M(b).ReadNum(1&): NEXT i
      END SUB

      FUNCTION RK2str
       xType=RK AND &H3
       IF (RK AND xRKInteger&)>0& THEN
        xInt=RK SHR 2&
        IF RK<0& THEN xInt=xInt OR &HC0000000
        IF (RK AND xRKby100&)>0& THEN RK2str=STR$(xInt/100&) ELSE RK2Str=STR$(xInt)
        EXIT FUNCTION
       ELSE
        MEMSET(VARPTR(xIEEE),0&,8&)
        xInt=(RK AND xRKEncoded&)
        MEMCPY(VARPTR(xIEEE)+4&,VARPTR(xInt),4&)
        IF (RK AND xRKby100&)>0& THEN RK2str=STR$(xIEEE/100.0#) ELSE RK2Str=STR$(xIEEE)
        EXIT FUNCTION
       END IF
      END FUNCTION

      FUNCTION StrRecLen 'returns bytes from ptr to next record
       DIM kk AS LONG
       sLength=M(b).ReadNum(2&): kk=sLength
       sCode=0??: sCode=M(b).ReadNum(1&)
       IF (sCode AND 1??)>0& THEN sLength=2??*sLength: kk=sLength 'String not compressed
       IF (sCode AND 8??)>0& THEN kk=M(b).ReadNum(2&): kk=sLength+4&*kk 'RichString
       IF (sCode AND 4??)>0& THEN i=M(b).ReadNum(4&): kk=kk+i  'Far East
       StrRecLen=kk
      END FUNCTION

      FUNCTION B2W(index AS LONG) AS WORD
       B2W=buf(index)+256??*buf(index+1&)
      END FUNCTION

      SUB ClearBookData
       nSheets(b)=0&: nSR(b)=0& : tSST(b)=0&: nSST(b)=0&
       FOR i=0& TO MaxSST&
        FOR j=0& TO 2&: SST(b,i,j)=0&: NEXT j
       NEXT i
       FOR i=0& TO MaxSheets&
        SheetName(b,i)=""
        FOR j=0& TO NumVars&: P(b,i,j)=0&: NEXT j
       NEXT i
      END SUB

'This uses OLE FAT to read file.  The code is not yet optimized.
      SUB ReadOLEFile
       DIM FATlen AS LONG, DIRptr AS LONG, FATindex AS LONG, FATptr AS LONG
       DIM BB AS LONG, NextFAT AS LONG, ptrFATindex AS LONG, EndFATindex AS LONG
       DIM WBptr AS LONG, FATseg AS LONG
       F.OPEN(FileSpec(b),fmOpenRead)
       F.Position=&H1E: i=F.ReadNum(2&): BB=2&^i  'size of big block sectors
       F.Position=&H2C: FATlen=F.ReadNum(4&)
       F.Position=&H30: i=F.ReadNum(4&): DIRptr=i*BB+BB
       F.Position=&H44: FATindex=F.ReadNum(4&): INC(FATindex)
'IF FATindex>0& THEN FATindex=FATindex*BB+BB 'FAT index exceeds OLE header
       M(b).Position=0&: ptrFATindex=&H4C: EndFATindex=BB

'Find Workbook entry
       WBptr=DIRptr
       F.Position=DIRptr+&H74: xInt=F.ReadNum(4&) 'may be offset into FAT
       IF (xInt<0&) OR (xInt>32&) THEN xInt=0&    'but only if it is positive and not too big
       FOR j=1& TO 3&: WBptr=WBptr+&H80
        F.Position=WBptr: i=F.ReadNum(4&)
        IF i=&H6F0057 THEN GOTO FoundWBptr
       NEXT j
       sERR="Workbook OLE directory entry not found": EXIT SUB
FoundWBptr:
       F.Position=WBptr+&H74: j=F.ReadNum(4&)
       IF j<=0& THEN j=xInt   'use the right offset into FAT
       P(b,0&,1&)=F.ReadNum(4&) 'BIFF8 size

       FOR k=1& TO FATlen  'do a FAT sector
'next we switch to FAT index extension, if applicable
        IF ptrFATindex>=EndFATindex THEN
         ptrFATindex=FATindex*BB  'end of OLE header or FAT index sector
         EndFATindex=ptrFATindex+BB
         F.Position=EndFATindex-4&: FATindex=F.ReadNum(4&): INC(FATindex)
        END IF

        F.Position=ptrFATindex: i=F.ReadNum(4&): ptrFATindex=ptrFATindex+4&
        IF i<0& THEN sERR="Bad FAT index": EXIT SUB
        FATptr=i*BB+BB: xNext=FATptr+BB: FATseg=FATptr
        IF k=1& THEN FATptr=FATseg+j*4& 'offset into FAT

        IF ptrFATindex=EndFATindex THEN NextFAT=FATindex ELSE NextFAT=F.ReadNum(4&): INC(NextFAT)
        j=0&

GetFATPointer:
        IF FATptr>=xNext THEN GOTO NextFATSector
        F.Position=FATptr: i=F.ReadNum(4&): FATptr=FATptr+4&
        IF j=0 THEN j=i-1&

        IF i=NextFAT THEN i=j+1&: GOTO LoadSector
        SELECT CASE i
        CASE &HFFFFFFFF: j=0&: GOTO GetFATPointer
        CASE &HFFFFFFFE  '-2 is EOF marker, but you read one more sector of user data
         IF M(b).Size<2048& THEN  'this because short OLE-generated files have bad DIRptr
          i=F.ReadNum(4&): j=i-1&: GOTO LoadSector
         END IF
        CASE &HFFFFFFFD: j=0&: GOTO GetFATPointer 'inserted garbage; skip it
        CASE &HFFFFFFFC: j=0&: GOTO GetFATPointer
        END SELECT

LoadSector:
        INC(j): F.Position=j*&H200: M(b).CopyFrom(F,&H200)
        IF i=-2& THEN GOTO LoadDone 'EOF
        IF i<>j THEN i=(i*4) MOD BB: FATptr=FATseg+i: j=0&
        GOTO GetFATPointer

NextFATSector:
       NEXT k

LoadDone:
       P(b,0&,2&)=M(b).Size: F.CLOSE
       IF P(b,0&,2&)<P(b,0&,1&) THEN sERR="All BIFF8 data not loaded"
      END SUB

'The following two subs are replaced by ReadOLEFile
'MS Excel corrupts certain files (to prevent access?) which we now undo
'SUB Uncorrupt
'xTmp=M(b).Pointer
'MEMCPY(VARPTR(buf(0&)),xTmp+&H800,&H800)
'MEMCPY(xTmp+&H800,xTmp+&H1000,&H1000)
'MEMCPY(xTmp+&H1800,VARPTR(buf(0&)),&H800)
'END SUB

'MS Excel may put trash bytes (to prevent access?) which we now remove
'SUB RemoveTrash
'DIM memptr As LONG
'memptr=0&: j=0&
'IF xNext<>&H1000 THEN memptr=xNext-&H2000
'TrashCycle:
'SELECT CASE j MOD 4&
'  CASE 0&: memptr=memptr+&H10000: xB2=&H81
'  CASE 1&: memptr=memptr+&H10000
'    IF xNext=&H1000 THEN xB2=&HFD ELSE xB2=&H01
'  CASE 2&:  xB2=&H81
'    IF xNext=&H1000 THEN memptr=memptr+&HF800 ELSE memptr=memptr+&H10000
'  CASE 3&: memptr=memptr+&H10000: xB2=&H01
'END SELECT
'IF memptr>M(b).Size THEN Exit SUB
'M(b).Position=memptr: xB1=M(b).ReadNum(1&)
'IF xB1=xB2 THEN ShiftBook(memptr,-512&) ELSE Exit SUB
'INC(j): Goto TrashCycle
'END SUB

      SUB FillFile(value AS LONG, amt AS LONG)
FillFileDone:
       IF (F.Position-&H200) MOD amt=0& THEN EXIT SUB
       F.WriteNum(value,4&): GOTO FillFileDone
      END SUB

      SUB ShiftBook(PTR AS LONG, nbytes AS LONG)
       DIM mfrom AS LONG, mdest AS LONG
       IF nbytes<0& THEN
        mdest=M(b).Pointer+PTR: mfrom=mdest-nbytes
        MEMCPY(mdest,mfrom,M(b).Size-(PTR-nbytes)+1&)
        M(b).Size=M(b).Size+nbytes
       ELSE
        mfrom=M(b).Size-1&: M(b).Size=M(b).Size+nbytes: mdest=M(b).Size-1&
MoveByteUp: 'this is a slow way to do it and should be improved
        MEMCPY(M(b).Pointer+mdest,M(b).Pointer+mfrom,1&): DEC(mdest): DEC(mfrom)
        IF mfrom>=PTR THEN GOTO MoveByteUp
       END IF
      END SUB

'Utility routines to display internal data
      SUB PrintSheetNames   'For CONSOLE application
       FOR i=0& TO nSheets(b): PRINT SheetName(b,i)
        FOR j=0& TO NumVars&: PRINT " "+RIGHT$(HEX$(P(b,i,j)),7&);: NEXT j
        PRINT: NEXT i
       END SUB

       SUB PrintSSTRecords
        PRINT "No. SST blocks=";STR$(nSST(b)+1&);" Strings in SST=";STR$(tSST(b))
        FOR j=0& TO nSST(b): PRINT STR$(SST(b,j,1&))+" ";: NEXT j
        PRINT
       END SUB

2003-06-09 17:34