PureBoard

Code: Alles auswählen

;Excel_PureBasic-file For BIFF 2.1 specifications To write Excel files. 
; 
;Class file For writing Microsoft Excel BIFF 2.1 files. 
; 
;This class is intended For users who do not want To use the huge 
;Jet Or ADO providers If they only want To export their Data To 
;an Excel compatible file. 

;Newer versions of Excel use the OLE Structure Storage methods 
;which are quite complicated. 



;constants To hold cell alignment 
    #xlsGeneralAlign = 0 
    #xlsLeftAlign = 1 
    #xlsCentreAlign = 2 
    #xlsRightAlign = 3 
    #xlsFillCell = 4 
    #xlsLeftBorder = 8 
    #xlsRightBorder = 16 
    #xlsTopBorder = 32 
    #xlsBottomBorder = 64 
    #xlsShaded = 128 

;constants To handle selecting the font For the cell 
    ;used by rgbAttr2 
    ;bits 0-5 handle the *picture* formatting, not bold/underline etc... 
    ;bits 6-7 handle the font number 
    #xlsFont0 = 0 
    #xlsFont1 = 64 
    #xlsFont2 = 128 
    #xlsFont3 = 192 

    ;used by rgbAttr1 
    ;bits 0-5 must be zero 
    ;bit 6 locked/unlocked 
    ;bit 7 hidden/not hidden 
    #xlsCellNormal = 0 
    #xlsCellLocked = 64 
    #xlsCellHidden = 128 


;set up variables To hold the spreadsheet's layout 
    #xlsLeftMargin = 38 
    #xlsRightMargin = 39 
    #xlsTopMargin = 40 
    #xlsBottomMargin = 41 


   ;add these enums together. For example: xlsBold + xlsUnderline 
   #xlsNoFormat = 0 
   #xlsBold = 1 
   #xlsItalic = 2 
   #xlsUnderline = 4 
   #xlsStrikeout = 8 


Structure FONT_RECORD 
   opcode.l ;49 
   length.l ;5+Len(fontname) 
   FontHeight.l 
    
   ;bit0 bold, bit1 italic, bit2 underline, bit3 strikeout, bit4-7 reserved 
   FontAttributes1.b 
   FontAttributes2.b ;reserved - always 0 
   FontNameLength.b 
EndStructure 


Structure PASSWORD_RECORD 
   opcode.l ;47 
   length.l ;Len(password) 
EndStructure 


Structure HEADER_FOOTER_RECORD 
   opcode.l  ;20 Header, 21 Footer 
   length.l  ;1+Len(text) 
   TextLength.b 
EndStructure 


Structure PROTECT_SPREADSHEET_RECORD 
   opcode.l ;18 
   length.l ;2 
   Protect.l 
EndStructure 

Structure FORMAT_COUNT_RECORD 
   opcode.l ;1f 
   length.l ;2 
   Count.l 
EndStructure 

Structure FORMAT_RECORD 
   opcode.l  ;1e 
   length.l  ;1+Len(format) 
   FormatLength.b;len(format) 
EndStructure ; + followed by the Format-Picture 

Structure COLWIDTH_RECORD 
   opcode.l  ;36 
   length.l  ;4 
   col1.b    ;first column 
   col2.b    ;last column 
   ColumnWidth.l ;at 1/256th of a character 
EndStructure 

;Beginning Of File record 
Structure BEG_FILE_RECORD 
  opcode.l 
  length.l 
  version.l 
  ftype.l 
EndStructure 

;End Of File record 
Structure END_FILE_RECORD 
  opcode.l 
  length.l 
EndStructure 

;true/false To print gridlines 
Structure PRINT_GRIDLINES_RECORD 
  opcode.l 
  length.l 
  PrintFlag.l 
EndStructure 

;Integer record 
Structure tInteger 
  opcode.l 
  length.l 
  Row.l  ;unsigned integer 
  col.l 
  
  ;rgbAttr1 handles whether cell is hidden and/Or locked 
  rgbAttr1.b 
  
  ;rgbAttr2 handles the Font# And Formatting assigned To this cell 
  rgbAttr2.b 
  
  ;rgbAttr3 handles the Cell Alignment/borders/shading 
  rgbAttr3.b 
  
  intValue.l   ;'the actual integer value 
EndStructure 

;Number record 
Structure tNumber 
  opcode.l 
  length.l 
  Row.l 
  col.l 
  rgbAttr1.b 
  rgbAttr2.b 
  rgbAttr3.b 
  NumberValue.l 
EndStructure 

;Label (Text) record 
Structure tText 
  opcode.l 
  length.l 
  Row.l 
  col.l 
  rgbAttr1.b 
  rgbAttr2.b 
  rgbAttr3.b 
  TextLength.b 
EndStructure 

Structure MARGIN_RECORD_LAYOUT 
  opcode.l 
  length.l 
  MarginValue.l ;  '8 bytes 
EndStructure 

Structure HPAGE_BREAK_RECORD 
  opcode.l 
  length.l 
  NumPageBreaks.l 
EndStructure 

Structure DEF_ROWHEIGHT_RECORD 
  opcode.l 
  length.l 
  RowHeight.l 
EndStructure 

Structure ROW_HEIGHT_RECORD 
  opcode.l;08 
  length.l;should always be 16 bytes 
  RowNumber.l 
  FirstColumn.l 
  LastColumn.l 
  RowHeight.l;written to file as 1/20ths of a point 
  internal.l 
  DefaultAttributes.b;set to zero for no default attributes 
  FileOffset.l 
  rgbAttr1.b 
  rgbAttr2.b 
  rgbAttr3.b 
EndStructure 

Global xlsFileNumber.l 
Global xlsBufferSize.l  ;If > 0 then buffer is active, also holds size of buffer. 
Global xlsBufferString.s 


;create an array that will hold the rows where a horizontal page 
;Break will be inserted just before. 
;Global xlsHorizPageBreakRows.l() 
Global xlsNumHorizPageBreaks.l 


Declare.l xlsCreateFile(mFileName$) 
Declare.l xlsCloseFile() 
Declare.l xlsInsertHorizPageBreak(lrow.l) 
Declare.l xlsWriteInteger(value,lrow,lcol,CellFont,CellAlignment,HiddenLocked,CellFormat) 
Declare.l xlsWriteNumber(value,lrow,lcol,CellFont,CellAlignment,HiddenLocked,CellFormat) 
Declare.l xlsWriteText(value$,lrow,lcol,CellFont,CellAlignment,HiddenLocked,CellFormat) 
Declare.l xlsWriteDate(DateString$,lrow,lcol,CellFont,CellAlignment,HiddenLocked,CellFormat) 
Declare.l xlsSetMargin(Margin,MarginValue) 
Declare.l xlsSetColumnWidth(FirstColumn,LastColumn,WidthValue) 
Declare.l xlsSetFont(FontName$,FontHeight,FontFormat) 
Declare.l xlsSetHeader(HeaderText$) 
Declare.l xlsSetFooter(FooterText$) 
Declare.l xlsSetFilePassword(PasswordText$) 
Declare.l xlsPrintGridLines(TrueFalse) 
Declare.l xlsProtectSpreadsheet(TrueFalse) 
Declare.l xlsWriteDefaultFormats() 
Declare.l xlsSetDefaultRowHeight(HeightValue) 
Declare.l xlsSetRowHeight(lrow,HeightValue) 
Declare.l ConvertRow(lrow.l) 
Declare.l ConvertCol(lcol.l) 
Declare.l DateToJulian(DateString$) 
Declare.s CTOD(PBDate.s) 
Declare.l xlsBuffer(TrueFalse,BufferSize) 
Declare.l UpdateBuffer(BufferString$) 
Declare.l Ubound(*Array)
Declare.l Lbound(*Array)

Procedure Ubound(*Array) 
ProcedureReturn PeekL(*Array-8) 
EndProcedure 

Procedure Lbound(*Array) 
ProcedureReturn PeekL(*Array) 
EndProcedure 



Procedure.l xlsCreateFile(mFileName$) 

    If ReadFile(0,mFileName$) > 0 
       CloseFile(0) 
       ClearError() 
       Function = -1 
       Goto raus
    EndIf 
    
    BEG_FILE_MARKER.BEG_FILE_RECORD 
    ;beginning of file 
    BEG_FILE_MARKER\opcode = 9 
    BEG_FILE_MARKER\length = 4 
    BEG_FILE_MARKER\version = 2 
    BEG_FILE_MARKER\ftype = 10 
        
    xlsFileNumber = FreeFile 
    OpenFile(xlsFileNumber,mFileName$) 
    
    ;if the buffer us active then save the data to the buffer 
    ;otherwise then simply write To the file. 
    If xlsBufferSize  
        stat = UpdateBuffer(Str(BEG_FILE_MARKER)) 
    Else 
        WriteWord(BEG_FILE_MARKER);  'must always be written first 
        ClearError() 
        Function = -1 
        Goto raus
    EndIf 
        
     ;write the default formats to the file 
     ;And Return If error occured. 
    If xlsWriteDefaultFormats 
    Else 
      ;create the Horizontal Page Break array 
      Dim xlsHorizPageBreakRows(0) 
      xlsNumHorizPageBreaks = 0 
    EndIf
      Function = 0  ;'return with no error 
      raus:
    
   ProcedureReturn Function 
EndProcedure 



Procedure.l xlsCloseFile() 
    If xlsFileNumber = 0 
       Function = -1 
       Goto raus1
    EndIf  
    
    ;write the horizontal page breaks If necessary 
    If xlsNumHorizPageBreaks > 0 
       ;the Horizontal Page Break array must be in sorted order. 
       ;Use a simple Bubble sort because the size of this array would 
       ;be pretty small most of the time. A QuickSort would probably 
       ;be overkill. 
         lLoop1.l 
         lLoop2.l 
         lTemp.l 
         For lLoop1 = UBound(xlsHorizPageBreakRows) To LBound(xlsHorizPageBreakRows) Step -1 
           For lLoop2 = LBound(xlsHorizPageBreakRows) + 1 To lLoop1 
             If xlsHorizPageBreakRows(lLoop2 - 1) > xlsHorizPageBreakRows(lLoop2) 
               lTemp = xlsHorizPageBreakRows(lLoop2 - 1) 
               xlsHorizPageBreakRows(lLoop2 - 1) = xlsHorizPageBreakRows(lLoop2) 
               xlsHorizPageBreakRows(lLoop2) = lTemp 
             EndIf 
           Next lLoop2 
         Next lLoop1 
              
        ;write the Horizontal Page Break Record 
        HORIZ_PAGE_BREAK.HPAGE_BREAK_RECORD 
        HORIZ_PAGE_BREAK\opcode = 27 
        HORIZ_PAGE_BREAK\length = 2 + (xlsNumHorizPageBreaks * 2) 
        HORIZ_PAGE_BREAK\NumPageBreaks = xlsNumHorizPageBreaks 

        If xlsBufferSize 
            stat = UpdateBuffer(Str(HORIZ_PAGE_BREAK)) 
        Else 
            WriteWord(HORIZ_PAGE_BREAK) 
            ClearError() 
            Function = -1 
            Goto raus1
        EndIf    
        
        ;now write the actual page Break values 
        For x = 1 To UBound(xlsHorizPageBreakRows) 
           st$ = Str(xlsHorizPageBreakRows(x)) 
           If xlsBufferSize 
               stat = UpdateBuffer(st$) 
           Else 
               WriteWord(st$) 
               ClearError() 
               Function = -1 
               Goto raus1
           EndIf    
        Next 
     EndIf
      
    END_FILE_MARKER.END_FILE_RECORD 
     ;End of file marker 
    END_FILE_MARKER\opcode = 10 
    
    If xlsBufferSize 
        ;set xlsBufferSize To -1 which will flag the UpdateBuffer routine 
        ;To flush the buffer. 
        xlsBufferSize = -1 
        stat = UpdateBuffer("") 
    EndIf 
        
    WriteWord(END_FILE_MARKER) 

    CloseFile(xlsFileNumber) 

    Function = 0  ;'return with no error code 
    raus1:

 ProcedureReturn Function 
EndProcedure 



Procedure.l xlsInsertHorizPageBreak(lrow) 

;the row And column values are written To the excel file as 
;unsigned integers. Therefore, must convert the longs To integer. 
    If lrow > 32767  
       Row = Int(Int(lrow - 65536) ) 
    Else 
       Row = Int(Int(lrow)) - 1    ;rows/cols in Excel binary file are zero based 
    EndIf 
        
    xlsNumHorizPageBreaks = xlsNumHorizPageBreaks + 1 
    Dim xlsHorizPageBreakRows(xlsNumHorizPageBreaks) 
    
    xlsHorizPageBreakRows(xlsNumHorizPageBreaks) = Row
    
    Function = 0 
  ProcedureReturn Function 
EndProcedure 



Procedure.l ConvertRow(lrow.l) 
;the row And column values are written To the excel file as 
;integers. Therefore, must convert the longs To integer. 
    
    If lrow > 32767 
       Function = Int(lrow - 65536) 
    Else 
       Function = Int(lrow) - 1    ;rows/cols in Excel binary file are zero based 
    EndIf 
ProcedureReturn Function 
EndProcedure 


Procedure.l ConvertCol(lcol.l) 
;the row And column values are written To the excel file as 
;integers. Therefore, must convert the longs To integer. 

    If lcol > 32767 
       Function = Int(lcol - 65536) 
    Else 
       Function = Int(lcol) - 1    ;rows/cols in Excel binary file are zero based 
    EndIf 
  ProcedureReturn Function 
EndProcedure 




Procedure.l xlsWriteInteger(value,lrow,lcol,CellFont,CellAlignment,HiddenLocked,CellFormat) 

    ;convert the row, col from LONG To INTEGER. 
    Row = Int(ConvertRow(lrow)) 
    Col = Int(ConvertCol(lcol)) 
    
    INTEGER_RECORD.tInteger 
    INTEGER_RECORD\opcode = 2 
    INTEGER_RECORD\length = 9 
    INTEGER_RECORD\Row = Row 
    INTEGER_RECORD\col = col 
    INTEGER_RECORD\rgbAttr1 = Int(HiddenLocked)
    INTEGER_RECORD\rgbAttr2 = Int(CellFont + CellFormat)
    INTEGER_RECORD\rgbAttr3 = Int(CellAlignment)
    INTEGER_RECORD\intValue = value 

    If xlsBufferSize 
       stat = UpdateBuffer(Str(INTEGER_RECORD))    
    Else 
       WriteWord(INTEGER_RECORD) 
       ClearError() 
       Function = -1 
       Goto raus2
     EndIf    

    Function = 0    ;Return with no error 
    raus2: 
   ProcedureReturn Function 
EndProcedure 



Procedure.l xlsWriteNumber(value,lrow,lcol,CellFont,CellAlignment,HiddenLocked,CellFormat) 

    ;convert the row, col from LONG To INTEGER. 
    Row = Int(ConvertRow(lrow)) 
    Col = Int(ConvertCol(lcol)) 

    NUMBER_RECORD.tNumber 
    NUMBER_RECORD\opcode = 3 
    NUMBER_RECORD\length = 15 
    NUMBER_RECORD\Row = Row 
    NUMBER_RECORD\col = col 
    NUMBER_RECORD\rgbAttr1 = Int(HiddenLocked) 
    NUMBER_RECORD\rgbAttr2 = Int(CellFont + CellFormat) 
    NUMBER_RECORD\rgbAttr3 = Int(CellAlignment) 
    NUMBER_RECORD\NumberValue = value 

    If xlsBufferSize  
       stat = UpdateBuffer(Str(NUMBER_RECORD))    
    Else 
       WriteWord(NUMBER_RECORD) 
       ClearError() 
       Function = -1 
       Goto raus3
    EndIf    

    Function = 0   ;Return with no error 
    raus3:
  ProcedureReturn Function 
EndProcedure 


Procedure.l xlsWriteText(value$,lrow,lcol,CellFont,CellAlignment,HiddenLocked,CellFormat) 

    ;convert the row, col from LONG To INTEGER. 
    Row = Int(ConvertRow(lrow)) 
    Col = Int(ConvertCol(lcol)) 

    b.b 
    st$ = value$ 
    l = Len(st$) 
    
    TEXT_RECORD.tText 
    TEXT_RECORD\opcode = 4 
    TEXT_RECORD\length = 10 
    ;Length of the text portion of the record 
    TEXT_RECORD\TextLength = l 
    
    ;Total length of the record 
    TEXT_RECORD\length = 8 + l 
    
    TEXT_RECORD\Row = Int(Row) 
    TEXT_RECORD\col = Int(col) 
      
    TEXT_RECORD\rgbAttr1 = Int(HiddenLocked) 
    TEXT_RECORD\rgbAttr2 = Int(CellFont + CellFormat) 
    TEXT_RECORD\rgbAttr3 = Int(CellAlignment) 
    
    ;Put record header 
    If xlsBufferSize 
       stat = UpdateBuffer(Str(TEXT_RECORD))    
    Else 
       WriteWord(TEXT_RECORD) 
    EndIf    
    
    ;Then the actual string Data 
    For a = 1 To l 
        b = Asc(Mid(st$, a, 1)) 
        If xlsBufferSize  
           stat = UpdateBuffer(Str(Int(b)))    
        Else 
           WriteByte(b) 
           ClearError() 
           Function = -1 
           Goto raus4
        EndIf   
    Next


    Function = 0   ;return with no error 
    raus4:
  ProcedureReturn Function 
EndProcedure 



Procedure.l xlsWriteDate(DateString$,lrow,lcol,CellFont,CellAlignment,HiddenLocked,CellFormat) 

    ;convert the row, col from LONG to INTEGER. 
    Row = Int(ConvertRow(lrow)) 
    Col = Int(ConvertCol(lcol)) 
    
    ;convert the DateString$ from YYYYMMDD To a Julian date number 
    value = (DateToJulian(DateString$) - DateToJulian("19000100")) + 1 
    
    NUMBER_RECORD.tNumber 
    NUMBER_RECORD\opcode = 3 
    NUMBER_RECORD\length = 15 
    NUMBER_RECORD\Row = Row 
    NUMBER_RECORD\col = col 
    NUMBER_RECORD\rgbAttr1 = Int(HiddenLocked) 
    NUMBER_RECORD\rgbAttr2 = Int(CellFont + CellFormat) 
    NUMBER_RECORD\rgbAttr3 = Int(CellAlignment) 
    NUMBER_RECORD\NumberValue = Int(value)
    

    If xlsBufferSize 
        stat = UpdateBuffer(Str(NUMBER_RECORD))    
    Else 
        WriteWord(NUMBER_RECORD) 
        ClearError() 
        Function = -1 
        Goto raus5
    EndIf    

    Function = 0   ;Return with no error 
    raus5: 
  ProcedureReturn Function 
EndProcedure 
  


Procedure.l xlsSetMargin(Margin,MarginValue) 

    ;write the spreadsheet's layout information (in inches) 
    MARGINRECORD.MARGIN_RECORD_LAYOUT 

    ;Margin& should be one of the following.... 
    ;xlsLeftMargin = 38 
    ;xlsRightMargin = 39 
    ;xlsTopMargin = 40 
    ;xlsBottomMargin = 41 
    
    MARGINRECORD\opcode = Margin 
    MARGINRECORD\length = 8 
    MARGINRECORD\MarginValue = MarginValue ; 'in inches 

    If xlsBufferSize 
        stat = UpdateBuffer(Str(MARGINRECORD))    
    Else 
        WriteWord(MARGINRECORD) 
        ClearError() 
        Function = -1 
        Goto raus6
    EndIf    

    Function = 0 
    raus6:
  ProcedureReturn Function 
EndProcedure 


Procedure.l xlsSetColumnWidth(FirstColumn,LastColumn,WidthValue) 

    COLWIDTH.COLWIDTH_RECORD 
    COLWIDTH\opcode = 36 
    COLWIDTH\length = 4 
    COLWIDTH\col1 = Int(FirstColumn) - 1 
    COLWIDTH\col2 = Int(LastColumn) - 1 
    COLWIDTH\ColumnWidth = WidthValue * 256  ;values are specified as 1/256 of a character 

    If xlsBufferSize 
        stat = UpdateBuffer(Str(COLWIDTH))    
    Else 
        WriteWord(COLWIDTH) 
        ClearError() 
        Function = -1 
        Goto raus7
    EndIf    

    Function = 0 
    raus7:
  ProcedureReturn Function 
EndProcedure 

Procedure.l xlsSetFont(FontName$,FontHeight,FontFormat) 

    ;you can set up To 4 fonts in the spreadsheet file. When writing a value such 
    ;as a Text Or Number you can specify one of the 4 fonts (numbered 0 To 3) 
    
    FONTNAME_RECORD.FONT_RECORD 
    
    l = Len(FontName$) 
    
    FONTNAME_RECORD\opcode = 49 
    FONTNAME_RECORD\length = 5 + l 
    FONTNAME_RECORD\FontHeight = FontHeight * 20 
    FONTNAME_RECORD\FontAttributes1 = Int(FontFormat)    ;bold/underline etc... 
    FONTNAME_RECORD\FontAttributes2 = Int(0)             ;reserved-always zero!! 
    FONTNAME_RECORD\FontNameLength = Int(l) 

    If xlsBufferSize 
        stat = UpdateBuffer(Str(FONTNAME_RECORD))    
    Else 
        WriteWord(FONTNAME_RECORD) 
    EndIf    

    ;Then the actual font name Data 
    b.b 
    For a = 1 To l 
       b = Asc(Mid(FontName$, a, 1)) 
       If xlsBufferSize 
           stat = UpdateBuffer(Str(Int(b)))    
       Else 
           WriteByte(b) 
           ClearError() 
           Function = -1 
           Goto raus8
       EndIf    

    Next 
         Function = 0 
         raus8:
  ProcedureReturn Function 
EndProcedure 




Procedure.l xlsSetHeader(HeaderText$) 

    HEADER_RECORD.HEADER_FOOTER_RECORD 
    
    l = Len(HeaderText$) 
    
    HEADER_RECORD\opcode = 20 
    HEADER_RECORD\length = 1 + l 
    HEADER_RECORD\TextLength = Int(l) 

    If xlsBufferSize 
       stat = UpdateBuffer(Str(HEADER_RECORD))    
    Else 
       WriteWord(HEADER_RECORD) 
    EndIf    

    ;Then the actual Header text 
    b.b 
    For a = 1 To l 
       b = Asc(Mid(HeaderText$, a, 1)) 
       If xlsBufferSize 
          stat = UpdateBuffer(Str(Int(b)))    
       Else 
          WriteByte(b) 
          ClearError() 
          Function = -1 
          Goto raus9 
       EndIf    
    Next 


    Function = 0 
    raus9:
  ProcedureReturn Function 
EndProcedure 




Procedure.l xlsSetFooter(FooterText$) 

    FOOTER_RECORD.HEADER_FOOTER_RECORD 
    
    l = Len(FooterText$) 
    
    FOOTER_RECORD\opcode = 21 
    FOOTER_RECORD\length = 1 + l 
    FOOTER_RECORD\TextLength = Int(l) 

    If xlsBufferSize 
       stat = UpdateBuffer(Str(FOOTER_RECORD))    
    Else 
       WriteWord(FOOTER_RECORD) 
    EndIf    

    ;Then the actual Header text 
    b.b 
    For a = 1 To l 
       b = Asc(Mid(FooterText$, a, 1)) 
       If xlsBufferSize 
          stat = UpdateBuffer(Str(Int(b)))    
       Else 
          WriteByte(b) 
          ClearError() 
          Function = -1 
          Goto raus10 
       EndIf    
    Next 

    Function = 0 
    raus10:
  ProcedureReturn Function 
EndProcedure 
  



Procedure.l xlsSetFilePassword(PasswordText$) 

    FILE_PASSWORD_RECORD.PASSWORD_RECORD 
    
    l = Len(PasswordText$) 
    
    FILE_PASSWORD_RECORD\opcode = 47 
    FILE_PASSWORD_RECORD\length = l 

    If xlsBufferSize 
       stat = UpdateBuffer(Str(FILE_PASSWORD_RECORD))
    Else 
       WriteWord(FILE_PASSWORD_RECORD) 
    EndIf    

    ;Then the actual Password text 
    b.b 
    For a = 1 To l 
       b = Asc(Mid(PasswordText$, a, 1)) 
       If xlsBufferSize 
          stat = UpdateBuffer(Str(Int(b)))    
       Else 
          WriteByte(b) 
          ClearError() 
          Function = -1 
          Goto raus11
       EndIf    
    Next 

    Function = 0 
    raus11:
  ProcedureReturn Function 
EndProcedure 





Procedure.l xlsPrintGridLines(TrueFalse) 

    GRIDLINES_RECORD.PRINT_GRIDLINES_RECORD 
    
    GRIDLINES_RECORD\opcode = 43 
    GRIDLINES_RECORD\length = 2 
    
    If TrueFalse = 0 
       GRIDLINES_RECORD\PrintFlag = 0 
    Else 
       GRIDLINES_RECORD\PrintFlag = 1 
    EndIf 
      
    If xlsBufferSize 
       stat = UpdateBuffer(Str(GRIDLINES_RECORD))    
    Else 
       WriteWord(GRIDLINES_RECORD) 
       ClearError() 
       Function = -1 
       Goto raus12
    EndIf    
    
    Function = 0 
    raus12:
  ProcedureReturn Function 
EndProcedure 




Procedure.l xlsProtectSpreadsheet(TrueFalse) 

    PROTECT_RECORD.PROTECT_SPREADSHEET_RECORD 
    
    PROTECT_RECORD\opcode = 18 
    PROTECT_RECORD\length = 2 
    
    If TrueFalse = 0 
       PROTECT_RECORD\Protect = 0 
    Else 
       PROTECT_RECORD\Protect = 1 
    EndIf 
      
    If xlsBufferSize 
       stat = UpdateBuffer(Str(PROTECT_RECORD))
    Else 
       WriteWord(PROTECT_RECORD) 
       ClearError() 
       Function = -1 
       Goto raus13
    EndIf    
    
    Function = 0 
    raus13:
  ProcedureReturn Function 
EndProcedure 
  


Procedure.l xlsWriteDefaultFormats() 
    
    cFORMAT_COUNT_RECORD.FORMAT_COUNT_RECORD 
    cFORMAT_RECORD.FORMAT_RECORD 
    lIndex.l 
    Dim aFormat.s(23) 
    l.l 
    q.s 
    q = Chr(34)
    
    aFormat(0) = "General" 
    aFormat(1) = "0" 
    aFormat(2) = "0.00" 
    aFormat(3) = "#,##0" 
    aFormat(4) = "#,##0.00" 
    aFormat(5) = "#,##0\ " + q + "$" + q + ";\-#,##0\ " + q + "$" + q 
    aFormat(6) = "#,##0\ " + q + "$" + q + ";[Red]\-#,##0\ " + q + "$" + q 
    aFormat(7) = "#,##0.00\ " + q + "$" + q + ";\-#,##0.00\ " + q + "$" + q 
    aFormat(8) = "#,##0.00\ " + q + "$" + q + ";[Red]\-#,##0.00\ " + q + "$" + q 
    aFormat(9) = "0%" 
    aFormat(10) = "0.00%" 
    aFormat(11) = "0.00E+00" 
    aFormat(12) = "yyyy-mm-dd" 
    aFormat(13) = "dd/\ mmm\ yy" 
    aFormat(14) = "dd/\ mmm" 
    aFormat(15) = "mmm\ yy" 
    aFormat(16) = "h:mm\ AM/PM" 
    aFormat(17) = "h:mm:ss\ AM/PM" 
    aFormat(18) = "hh:mm" 
    aFormat(19) = "hh:mm:ss" 
    aFormat(20) = "dd/mm/yy\ hh:mm" 
    aFormat(21) = "##0.0E+0" 
    aFormat(22) = "mm:ss" 
    aFormat(23) = "@" 
    
    cFORMAT_COUNT_RECORD\opcode = $1F 
    cFORMAT_COUNT_RECORD\length = $2 
    cFORMAT_COUNT_RECORD\Count = Int(UBound(aFormat)) 

    If xlsBufferSize 
       stat = UpdateBuffer(Str(cFORMAT_COUNT_RECORD))
    Else 
       WriteWord(cFORMAT_COUNT_RECORD) 
    EndIf 
    
    For lIndex = LBound(aFormat) To UBound(aFormat) 
        l = Len(aFormat(lIndex)) 

        cFORMAT_RECORD\opcode = $1E 
        cFORMAT_RECORD\length = l + 1 
        cFORMAT_RECORD\FormatLength = l 

        If xlsBufferSize 
           stat = UpdateBuffer(Str(cFORMAT_RECORD))    
        Else 
           WriteWord(cFORMAT_RECORD) 
        EndIf    
    
        ;Then the actual format 
        b.b 
        a.l 
        For a = 1 To l 
           b = Asc(Mid(aFormat(lIndex), a, 1)) 
           If xlsBufferSize 
              stat = UpdateBuffer(Str(Int(b)))    
           Else 
              WriteByte(b) 
              ClearError() 
              Function = -1 
              Goto raus14 
           EndIf    
        Next 
    Next 

    Function = 0 
    raus14:
  ProcedureReturn Function 
EndProcedure  



Procedure.l xlsSetDefaultRowHeight(HeightValue) 

;Height is defined in units of 1/20th of a point. Therefore, a 10-point font 
;would be 200 (i.e. 200/20 = 10). This function takes a HeightValue such as 
;4 point And converts it the correct size before writing it To the file. 

    DEFHEIGHT.DEF_ROWHEIGHT_RECORD 
    DEFHEIGHT\opcode = 37 
    DEFHEIGHT\length = 2 
    DEFHEIGHT\RowHeight = HeightValue& * 20  ;convert points To 1/20ths of point 

    If xlsBufferSize 
       stat = UpdateBuffer(Str(DEFHEIGHT))    
    Else 
       WriteWord(DEFHEIGHT) 

       ClearError()
       Function = -1 
       Goto raus15
    EndIf    
    Function = 0 
    raus15: 
  ProcedureReturn Function 
EndProcedure  


Procedure.l xlsSetRowHeight(lrow,HeightValue) 

    ;convert the row, col from LONG To INTEGER. 
    Row = Int(ConvertRow(lrow)) 

    ;Height is defined in units of 1/20th of a point. Therefore, a 10-point font 
    ;would be 200 (i.e. 200/20 = 10). This function takes a HeightValue such as 
    ;14 point And converts it the correct size before writing it To the file. 

    ROWHEIGHTREC.ROW_HEIGHT_RECORD 
    ROWHEIGHTREC\opcode = 8 
    ROWHEIGHTREC\length = 16 
    ROWHEIGHTREC\RowNumber = Row 
    ROWHEIGHTREC\FirstColumn = 0 
    ROWHEIGHTREC\LastColumn = 256 
    ROWHEIGHTREC\RowHeight = HeightValue * 20 ;convert points To 1/20ths of point 
    ROWHEIGHTREC\internal = 0 
    ROWHEIGHTREC\DefaultAttributes = 0 
    ROWHEIGHTREC\FileOffset = 0 
    ROWHEIGHTREC\rgbAttr1 = 0 
    ROWHEIGHTREC\rgbAttr2 = 0 
    ROWHEIGHTREC\rgbAttr3 = 0 

    If xlsBufferSize 
       stat = UpdateBuffer(Str(ROWHEIGHTREC))  
    Else 
       WriteWord(ROWHEIGHTREC) 
       ClearError() 
       Function = -1 
       Goto raus16
    EndIf    
    Function = 0 
    raus16:
  ProcedureReturn Function 
EndProcedure 


 Procedure.l DateToJulian(DateString$) 

  ;DateString$ must be in YYYYMMDD 
  
  Elapsed.l 
  
  If Len(DateString$) <> 8 
     Function = 0 
     Else    

  Year.l = Val(Left(DateString$, 4)) 
  month = Val(Mid(DateString$, 5, 2)) 
  day = Val(Right(DateString$, 2)) 
  
  If month < 3                      ; January or February? 
     month = month + 12                 ; 13th Or 14th month .... 
     year+1                              ; .... of prev. year 
  EndIf 
  
  Elapsed = Int(365.25*(year + 4712))  ; years elapsed 
  Elapsed =Elapsed - (year / 100)      ; substract century leapdays 
  Elapsed = Elapsed + (year / 400)      ; re-add valid ones 
  Elapsed = Elapsed + Int(30.6 * (month - 1) + 0.2) ; months elapsed + adjustm. 
  Function = Elapsed + day               ; days of final month 
  EndIf 
ProcedureReturn Function 
EndProcedure 



Procedure.s CTOD$(PBDate.s) 
;¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤ 
;Converts a PowerBASIC formated date string into an xBase date 
; Usage:   ans$ = CTOD("12-13-2001") 
;          ans$ = "20011213" 
;¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤ 
;First parse PBDate 
;Dim month$, day$, year$ 
;Dim ChekYear& 

  month$ = RemoveString(Str(PBDate),"-", 1)     ;month 
  day$ = RemoveString(Str(PBDate),"-", 2)       ;day 
  year$ = RemoveString(Str(PBDate),"-", 3)      ;year 

  ChekYear = Val(year$) 

; Adjust If user enters only 2 digit year 
   If ChekYear < 80       ;assume we've rolled into the Next century 
      year$ = "20" + year$ 
   ElseIf ChekYear < 100   ;between 1980 And 1999 
      year$ = "19" + year$ 
   EndIf 

; Force the reformat of strings into proper xBase length. 
  month$ = FormatDate("%mm",Val(month$)) 
  day$ = FormatDate("%dd",Val(day$)) 
  year$ = FormatDate("%yyyy",Val(year$)) 


  Function$ = year$ + month$ + day$

ProcedureReturn Function$
EndProcedure  


Procedure.l xlsBuffer(TrueFalse,BufferSize) 

    If BufferSize <= 0 
    Goto raus17
    If TrueFalse <> 0 
       xlsBufferSize = BufferSize  ;flag that buffer is active & also contains the buffer size 
       xlsBufferString$ = Space(xlsBufferSize) 
    EndIf    
    EndIf 
    raus17:
ProcedureReturn Function 
EndProcedure  
  

Procedure.l UpdateBuffer(*BufferData$) 

    Static CurBufferPos 
    
    ;If xlsBufferSize equals -1 then the flag To flush the buffer has 
    ;been set And the file is about To be closed. 
    If xlsBufferSize = -1  
       WriteString(Left(xlsBufferString$, CurBufferPos)) 
       ;reset the buffer so old Data does not get carried forward 
       ;To any new file being created. 
       xlsBufferString$ = "" 
       CurBufferPos = 0 
     Else
    ;If the current Data would be too big For the buffer then flush 
    ;the buffer And reset its size. 
    If Len(BufferData$) + CurBufferPos > xlsBufferSize  
       WriteString(Left(xlsBufferString$, CurBufferPos)) 
       CurBufferPos = 0 
    EndIf 
    
    ;write the Data To the buffer And update the buffer size indicator 
   BufferData$ = Mid(xlsBufferString$,CurBufferPos, CurBufferPos + 1)  
    CurBufferPos = CurBufferPos + Len(BufferData$) 
  EndIf          
 
ProcedureReturn CurBufferPos 
EndProcedure 

;Hauptprogramm ab hier
;
#XLSTRUE=1
#XLSFALSE=0
 ; starttime! = TIMER
    ;enable the buffer. This is optional, but enabling a buffer will speed
    ;up file access.
     stat = xlsBuffer(#XLSTRUE, 512*1024)  ;a 512K buffer
    ;Create the new spreadsheet
     mFileName$=".\vbtest.xls"  ;create spreadsheet in the current directory
     stat = xlsCreateFile(mFileName$)
    ;stat returns non-zero if an error occured.

    ;set a Password for the file. If set, the rest of the spreadsheet will
    ;be encrypted. If a password is used it must immediately follow the
    ;xlsCreateFile function call.

    ;This is different then protecting the spreadsheet (see below).
    ;NOTE: For some reason this function does not work. Excel will
    ;recognize that the file is password protected, but entering the password
    ;will not work. Also, the file is not encrypted. Therefore, do not use
    ;this function until I can figure out why it doesn;t work. There is not
    ;much documentation on this function available.
    ;xlsSetFilePassword("whatever")


    ;specify whether to print the gridlines or not
    ;this should come before the setting of fonts and margins
     stat = xlsPrintGridLines(#XLSTRUE)


    ;it is a good idea to set margins, fonts and column widths
    ;prior to writing any text/numerics to the spreadsheet. These
    ;should come before setting the fonts.

     stat = xlsSetMargin(#xlsTopMargin, 1.5)   ;set to 1.5 inches
     stat = xlsSetMargin(#xlsLeftMargin, 1.5)
     stat = xlsSetMargin(#xlsRightMargin, 1.5)
     stat = xlsSetMargin(#xlsBottomMargin, 1.5)


    ;Up to 4 fonts can be specified for the spreadsheet. This is a
    ;limitation of the Excel 2.1 format. For each value written to the
    ;spreadsheet you can specify which font to use.

     stat = xlsSetFont("Arial", 10, #xlsNoFormat)             ;font0
     stat = xlsSetFont("Arial", 10, #xlsBold)                 ;font1
     stat = xlsSetFont("Arial", 10, #xlsBold + #xlsUnderline) ;font2
     stat = xlsSetFont("Courier", 18, #xlsItalic)             ;font3


    ;Column widths are specified in Excel as 1/256th of a character.
     stat = xlsSetColumnWidth(1, 1, 50)

    ;set the global row height for the entire spreadsheet
     stat = xlsSetDefaultRowHeight(16)

    ;set the height of the first two rows a little bigger to allow for the
    ;title of the spreadsheet.
     stat = xlsSetRowHeight(1, 24)
     stat = xlsSetRowHeight(2, 24)


    ;set any header or footer that you want to print on
    ;every page. This text will be centered at the top and/or
    ;bottom of each page. The font will always be the font that
    ;is specified as font0, therefore you should only set the
    ;header/footer after specifying the fonts through SetFont.
     stat = xlsSetHeader("This is the header")
     stat = xlsSetFooter("This is the footer")


    ;write some data to the spreadsheet
     stat = xlsWriteInteger(20, 6, 1, #xlsFont0, #xlsLeftAlign, #xlsCellNormal, 0)

    ;write a cell with a shaded number with a bottom border
     stat = xlsWriteNumber(12123.456, 7, 1, #xlsFont1, #xlsrightAlign + #xlsBottomBorder + #xlsShaded, #xlsCellNormal, 0)

    ;write a normal left aligned string using font2 (bold & underline)
     stat = xlsWriteText("This is a test string", 8, 1, #xlsFont2, #xlsLeftAlign, #xlsCellNormal, 0)

    ;write a locked cell. The cell will not be able to be overwritten, BUT you
    ;must set the sheet PROTECTION to on before it will take effect!!!
     stat = xlsWriteText("This cell is locked.", 9, 1, #xlsFont3, #xlsLeftAlign, #xlsCellLocked, 0)

    ;fill the cell with "F";s
     stat = xlsWriteText("F", 10, 1, #xlsFont3, #xlsFillCell, #xlsCellNormal, 0)

    ;write a hidden cell to the spreadsheet. This only works for cells
    ;that contain formulae. Text, Number, Integer value text can not be hidden
    ;using this feature. It is included here for the sake of completeness.
     stat = xlsWriteText("If this were a formula it would be hidden!", 11, 1, #xlsFont0, #xlsCentreAlign, #xlsCellHidden, 0)

    ;write a date to the file. Dates can be written as literal text strings but doing so will not allow
    ;the date to be formatted. The date will be eventually written as a number after conversion to a
    ;Julian date number.
    ;Write todays date..... Use format #12 mm/dd/yy (you can change the different formats by modifying
    ;the code in xlsWriteDefaultFormats. The date is expected to be in the YYYYMMDD format. You can convert
    ;from mm-dd-yyyy format to YYYYMMDD by calling the CTOD$ function.
    mDate$ = CTOD(Str(Date()))
    
    stat = xlsWriteDate(mDate$, 15, 1, #xlsFont1, #xlsLeftAlign, #xlsCellNormal, 12)

    mDate$ = "19991128"
    stat = xlsWriteDate(mDate$, 16, 1, #xlsFont1, #xlsLeftAlign, #xlsCellNormal, 13)

    mDate$ = "20000331"
    stat = xlsWriteDate(mDate$, 17, 1, #xlsFont1, #xlsLeftAlign, #xlsCellNormal, 14)

    mDate$ = "20010630"
    stat = xlsWriteDate(mDate$, 18, 1, #xlsFont1, #xlsLeftAlign, #xlsCellNormal, 15)

    mDate$ = "19991023"
    stat = xlsWriteDate(mDate$, 19, 1, #xlsFont1, #xlsLeftAlign, #xlsCellNormal, 20)

    ;insert a page break
    stat = xlsInsertHorizPageBreak(20)


    ;write consecutive numbers in the column
    ;This demonstrates that this Excel code can exceed the normal BIFF 2.1 and Excel 95 row limit
    ;of 32,767 rows.
    NumRows.l = 50000
    For x.l = 1 To NumRows
    stat = xlsWriteNumber(x, 20+x, 1, #xlsFont1, #xlsLeftAlign, #xlsCellNormal, 0)
    Next


    ;PROTECT the spreadsheet so any cells specified as LOCKED will not be
    ;overwritten. Also, all cells with HIDDEN set will hide their formulae.
    ;PROTECT does not use a password.
    stat = xlsProtectSpreadsheet(#XLSTRUE)


    ;Finally, close the spreadsheet
    stat = xlsCloseFile()


    ;endtime! = TIMER

    MessageRequester("INFO","Excel BIFF Spreadsheet created")

Code: Alles auswählen

; All kind of constants and structures needed to work with the VARIANT type.
; The VARIANT type is used by COM components like ActiveX and others.

Enumeration
  #VT_EMPTY           = 0
  #VT_NULL            = 1
  #VT_I2              = 2
  #VT_I4              = 3
  #VT_R4              = 4
  #VT_R8              = 5
  #VT_CY              = 6
  #VT_DATE            = 7
  #VT_BSTR            = 8
  #VT_DISPATCH        = 9
  #VT_ERROR           = 10
  #VT_BOOL            = 11
  #VT_VARIANT         = 12
  #VT_UNKNOWN         = 13
  #VT_DECIMAL         = 14
  #VT_I1              = 16
  #VT_UI1             = 17
  #VT_UI2             = 18
  #VT_UI4             = 19
  #VT_I8              = 20
  #VT_UI8             = 21
  #VT_INT             = 22
  #VT_UINT            = 23
  #VT_VOID            = 24
  #VT_HRESULT         = 25
  #VT_PTR             = 26
  #VT_SAFEARRAY       = 27
  #VT_CARRAY          = 28
  #VT_USERDEFINED     = 29
  #VT_LPSTR           = 30
  #VT_LPWSTR          = 31
  #VT_RECORD          = 36
  #VT_FILETIME        = 64
  #VT_BLOB            = 65
  #VT_STREAM          = 66
  #VT_STORAGE         = 67
  #VT_STREAMED_OBJECT = 68
  #VT_STORED_OBJECT   = 69
  #VT_BLOB_OBJECT     = 70
  #VT_CF              = 71
  #VT_CLSID           = 72
  #VT_BSTR_BLOB       = $fff
  #VT_VECTOR          = $1000
  #VT_ARRAY           = $2000
  #VT_BYREF           = $4000
  #VT_RESERVED        = $8000
  #VT_ILLEGAL         = $ffff
  #VT_ILLEGALMASKED   = $fff
  #VT_TYPEMASK        = $fff
EndEnumeration               

Structure DOUBLE        ; You cant use this type without a special function that generates double values
  high.l
  low.l
EndStructure

Structure BRECORD       ; No idea where this is used
  pvRecord.l;
  IRecordInfo.l
EndStructure

Structure VARIANT       ; 16 bytes
  vt.w
  wReserved1.w
  wReserved2.w   
  wReserved3.w
  StructureUnion
    bVal.b              ; 1 byte, 8-bits
    iVal.w              ; 2 bytes, 16-bits
    lVal.l              ; 4 bytes, 32-bits
    value.l             ; same as lVal, defined for compatibility reasons
    dVal.DOUBLE         ; 8 bytes, 64-bits
    boolVal.w           ; boolean TRUE ($FFFF) or FALSE ($0000), see below
    bstrVal.l           ; pointer to BSTR (unicode string)
    scode.l             ; special code, e.g. for optional parameters, see below
    record.BRECORD
  EndStructureUnion
EndStructure

Structure SIGNSCALE
  scale.b               ; The number of decimal places for the number. Valid values are from 0 To 28.
  sign.b                ; 0 for positive numbers or DECIMAL_NEG for negative numbers. So -1 is represented as 1 with the DECIMAL_NEG bit set.
EndStructure

Structure DECIMAL      ; Special type of VARIANT, also 16 bytes
  wReserved.w
  signscale.SIGNSCALE
  high32.l
  low64.DOUBLE
EndStructure
 
Structure pToVariant   ; Used to pass a VARIANT to a method when you can't us a pointer, also 16 bytes
  a.l
  b.l
  c.l
  d.l
EndStructure

#VARIANT_TRUE   = $FFFF ; Variant version of TRUE
#VARIANT_FALSE  = $0000 ; Variant version of FALSE