excel.inc

一个可以让powerbasic直接创建 Excel 的dll 模块

'Excel.inc - Include file for BIFF 2.1 specifications to write Excel files.
'
'Converted from VB source to PowerBasic, November 2001.
'Paul Squires (2001) [e-mail] (Freeware)
'
'Copyright (c) 2001 by Paul Squires.
'Although this code is available for free, the author retains the copyright, which means that you 
'cannot do anything with it that is not expressly allowed by the author. In general terms, the author
'would allow the programmer to incorporate the code into their applications. Selling the code by 
'itself is prohibited. 
'
'
'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.

'Paul Squires, November 10, 2001
'[e-mail]


'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


Type FONT_RECORD
   opcode As Integer  '49
   length As Integer  '5+len(fontname)
   FontHeight As Integer
   
   'bit0 bold, bit1 italic, bit2 underline, bit3 strikeout, bit4-7 reserved
   FontAttributes1 As Byte
   FontAttributes2 As Byte  'reserved - always 0
   FontNameLength As Byte
End Type


Type PASSWORD_RECORD
   opcode As Integer  '47
   length As Integer  'len(password)
End Type


Type HEADER_FOOTER_RECORD
   opcode As Integer  '20 Header, 21 Footer
   length As Integer  '1+len(text)
   TextLength As Byte
End Type


Type PROTECT_SPREADSHEET_RECORD
   opcode As Integer  '18
   length As Integer  '2
   Protect As Integer
End Type

Type FORMAT_COUNT_RECORD
   opcode As Integer  '1f
   length As Integer '2
   Count As Integer
End Type

Type FORMAT_RECORD
   opcode As Integer  '1e
   length As Integer  '1+len(format)
   FormatLength As Byte 'len(format)
End Type '+ followed by the Format-Picture

Type COLWIDTH_RECORD
   opcode As Integer  '36
   length As Integer  '4
   col1 As Byte       'first column
   col2 As Byte       'last column
   ColumnWidth As Integer   'at 1/256th of a character
End Type

'Beginning Of File record
Type BEG_FILE_RECORD
  opcode As Integer
  length As Integer
  version As Integer
  ftype As Integer
End Type

'End Of File record
Type END_FILE_RECORD
  opcode As Integer
  length As Integer
End Type

'true/false to print gridlines
Type PRINT_GRIDLINES_RECORD
  opcode As Integer
  length As Integer
  PrintFlag As Integer
End Type

'Integer record
Type tInteger
  opcode As Integer
  length As Integer
  Row As Integer     'unsigned integer
  col As Integer
  
  'rgbAttr1 handles whether cell is hidden and/or locked
  rgbAttr1 As Byte
  
  'rgbAttr2 handles the Font# and Formatting assigned to this cell
  rgbAttr2 As Byte
  
  'rgbAttr3 handles the Cell Alignment/borders/shading
  rgbAttr3 As Byte
  
  intValue As Integer  'the actual integer value
End Type

'Number record
Type tNumber
  opcode As Integer
  length As Integer
  Row As Integer
  col As Integer
  rgbAttr1 As Byte
  rgbAttr2 As Byte
  rgbAttr3 As Byte
  NumberValue As Double  '8 Bytes
End Type

'Label (Text) record
Type tText
  opcode As Integer
  length As Integer
  Row As Integer
  col As Integer
  rgbAttr1 As Byte
  rgbAttr2 As Byte
  rgbAttr3 As Byte
  TextLength As Byte
End Type

Type MARGIN_RECORD_LAYOUT
  opcode As Integer
  length As Integer
  MarginValue As Double  '8 bytes
End Type

Type HPAGE_BREAK_RECORD
  opcode As Integer
  length As Integer
  NumPageBreaks As Integer
End Type

Type DEF_ROWHEIGHT_RECORD
  opcode As Integer
  length As Integer
  RowHeight As Integer
End Type

Type ROW_HEIGHT_RECORD
  opcode As Integer  '08
  length As Integer  'should always be 16 bytes
  RowNumber As Integer
  FirstColumn As Integer
  LastColumn As Integer
  RowHeight As Integer  'written to file as 1/20ths of a point
  internal As Integer
  DefaultAttributes As Byte  'set to zero for no default attributes
  FileOffset As Integer
  rgbAttr1 As Byte
  rgbAttr2 As Byte
  rgbAttr3 As Byte
End Type

Global xlsFileNumber As Long
Global xlsBufferSize As Long  'if > 0 then buffer is active, also holds size of buffer.
Global xlsBufferString As String


'create an array that will hold the rows where a horizontal page
'break will be inserted just before.
Global xlsHorizPageBreakRows() As Long
Global xlsNumHorizPageBreaks As Long


Declare Function xlsCreateFile(mFileName$) As Long
Declare Function xlsCloseFile() As Long
Declare Function xlsInsertHorizPageBreak(ByVal lrow As Long) As Long
Declare Function xlsWriteInteger(ByVal value%, ByVal lrow&, ByVal lcol&, ByVal CellFont&, ByVal CellAlignment&, ByVal HiddenLocked&, ByVal CellFormat&) As Long
Declare Function xlsWriteNumber(ByVal value#, ByVal lrow&, ByVal lcol&, ByVal CellFont&, ByVal CellAlignment&, ByVal HiddenLocked&, ByVal CellFormat&) As Long
Declare Function xlsWriteText(value$, ByVal lrow&, ByVal lcol&, ByVal CellFont&, ByVal CellAlignment&, ByVal HiddenLocked&, ByVal CellFormat&) As Long
Declare Function xlsWriteDate(DateString$, ByVal lrow&, ByVal lcol&, ByVal CellFont&, ByVal CellAlignment&, ByVal HiddenLocked&, ByVal CellFormat&) As Long
Declare Function xlsSetMargin(ByVal Margin&, ByVal MarginValue#) As Long
Declare Function xlsSetColumnWidth(ByVal FirstColumn&, ByVal LastColumn&, ByVal WidthValue&) As Long
Declare Function xlsSetFont(FontName$, ByVal FontHeight&, ByVal FontFormat&) As Long
Declare Function xlsSetHeader(HeaderText$) As Long
Declare Function xlsSetFooter(FooterText$) As Long
Declare Function xlsSetFilePassword(PasswordText$) As Long
Declare Function xlsPrintGridLines(ByVal TrueFalse&) As Long
Declare Function xlsProtectSpreadsheet(ByVal TrueFalse&) As Long
Declare Function xlsWriteDefaultFormats() As Long
Declare Function xlsSetDefaultRowHeight(ByVal HeightValue&) As Long
Declare Function xlsSetRowHeight(ByVal lrow&, ByVal HeightValue&) As Long
Declare Function ConvertRow(ByVal lrow As Long) As Integer
Declare Function ConvertCol(ByVal lcol As Long) As Integer
Declare Function DateToJulian&(DateString$) As Long
Declare Function CTOD(PBDate As String) As String
Declare Function xlsBuffer(ByVal TrueFalse&, ByVal BufferSize&) As Long
Declare Function UpdateBuffer(BufferString$) As Long



Function xlsCreateFile(mFileName$) As Long

    If Dir$(mFileName$) > "" Then
       Kill mFileName$
       If ErrClear Then 
          Function = -1
          Exit Function
       End If   
    End If
    
    Dim BEG_FILE_MARKER As 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
    Open mFileName$ For Binary As #xlsFileNumber
    
    'if the buffer us active then save the data to the buffer
    'otherwise then simply write to the file.
    If xlsBufferSize Then
        stat& = UpdateBuffer((BEG_FILE_MARKER))
    Else
        Put #xlsFileNumber, , BEG_FILE_MARKER  'must always be written first
        If ErrClear Then 
           Function = -1
           Exit Function
        End If   
    End If
        
    'write the default formats to the file
    'and return if error occured.
    If xlsWriteDefaultFormats Then Exit Function
    
    'create the Horizontal Page Break array
    ReDim xlsHorizPageBreakRows(0)
    xlsNumHorizPageBreaks = 0
    
    Function = 0  'return with no error
    
End Function



Function xlsCloseFile() As Long

    If xlsFileNumber = 0 Then 
       Function = -1
       Exit Function
    End If   
    
    'write the horizontal page breaks if necessary
    If xlsNumHorizPageBreaks > 0 Then
       '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.
         Dim lLoop1 As Long
         Dim lLoop2 As Long
         Dim lTemp As Long
         For lLoop1 = UBound(xlsHorizPageBreakRows) To LBound(xlsHorizPageBreakRows) Step -1
           For lLoop2 = LBound(xlsHorizPageBreakRows) + 1 To lLoop1
             If xlsHorizPageBreakRows(lLoop2 - 1) > xlsHorizPageBreakRows(lLoop2) Then
               lTemp = xlsHorizPageBreakRows(lLoop2 - 1)
               xlsHorizPageBreakRows(lLoop2 - 1) = xlsHorizPageBreakRows(lLoop2)
               xlsHorizPageBreakRows(lLoop2) = lTemp
             End If
           Next lLoop2
         Next lLoop1
              
       'write the Horizontal Page Break Record
        Dim HORIZ_PAGE_BREAK As HPAGE_BREAK_RECORD
        HORIZ_PAGE_BREAK.opcode = 27
        HORIZ_PAGE_BREAK.length = 2 + (xlsNumHorizPageBreaks * 2)
        HORIZ_PAGE_BREAK.NumPageBreaks = xlsNumHorizPageBreaks

        If xlsBufferSize Then
            stat& = UpdateBuffer((HORIZ_PAGE_BREAK))
        Else
            Put #xlsFileNumber, , HORIZ_PAGE_BREAK
            If ErrClear Then 
               Function = -1
               Exit Function
            End If   
        End If    
        
        'now write the actual page break values
        For x& = 1 To UBound(xlsHorizPageBreakRows)
           st$ = Mki$(xlsHorizPageBreakRows(x&))
           If xlsBufferSize Then
               stat& = UpdateBuffer(st$)
           Else
               Put #xlsFileNumber, , st$
               If ErrClear Then 
                  Function = -1
                  Exit Function
               End If   
           End If    
        Next
    End If
     
    Dim END_FILE_MARKER As END_FILE_RECORD
    'end of file marker
    END_FILE_MARKER.opcode = 10
    
    If xlsBufferSize Then
        'set xlsBufferSize to -1 which will flag the UpdateBuffer routine
        'to flush the buffer.
        xlsBufferSize = -1
        stat& = UpdateBuffer("")
    End If
        
    Put #xlsFileNumber, , END_FILE_MARKER

    Close #xlsFileNumber

    Function = 0  'return with no error code
    
End Function



Function xlsInsertHorizPageBreak(ByVal lrow As Long) As Long

'the row and column values are written to the excel file as
'unsigned integers. Therefore, must convert the longs to integer.
    If lrow > 32767 Then
       Row% = CInt(lrow - 65536)
    Else
       Row% = CInt(lrow) - 1    'rows/cols in Excel binary file are zero based
    End If
        
    xlsNumHorizPageBreaks = xlsNumHorizPageBreaks + 1
    ReDim Preserve xlsHorizPageBreakRows(xlsNumHorizPageBreaks)
    
    xlsHorizPageBreakRows(xlsNumHorizPageBreaks) = Row%
    
    Function = 0

End Function



Function ConvertRow(ByVal lrow As Long) As Integer
'the row and column values are written to the excel file as
'integers. Therefore, must convert the longs to integer.
    
    If lrow > 32767 Then
       Function = CInt(lrow - 65536)
    Else
       Function = CInt(lrow) - 1    'rows/cols in Excel binary file are zero based
    End If
  
End Function


Function ConvertCol(ByVal lcol As Long) As Integer
'the row and column values are written to the excel file as
'integers. Therefore, must convert the longs to integer.

    If lcol > 32767 Then
       Function = CInt(lcol - 65536)
    Else
       Function = CInt(lcol) - 1    'rows/cols in Excel binary file are zero based
    End If

End Function




Function xlsWriteInteger(ByVal value%, ByVal lrow&, ByVal lcol&, ByVal CellFont&, ByVal CellAlignment&, ByVal HiddenLocked&, ByVal CellFormat&) As Long

    'convert the row, col from LONG to INTEGER.
    Row% = ConvertRow(lrow&)
    Col% = ConvertCol(lcol&)
    
    Dim INTEGER_RECORD As tInteger
    INTEGER_RECORD.opcode = 2
    INTEGER_RECORD.length = 9
    INTEGER_RECORD.Row = Row%
    INTEGER_RECORD.col = col%
    INTEGER_RECORD.rgbAttr1 = CByt(HiddenLocked&)
    INTEGER_RECORD.rgbAttr2 = CByt(CellFont& + CellFormat&)
    INTEGER_RECORD.rgbAttr3 = CByt(CellAlignment&)
    INTEGER_RECORD.intValue = value%

    If xlsBufferSize Then
       stat& = UpdateBuffer((INTEGER_RECORD))    
    Else
       Put #xlsFileNumber, , INTEGER_RECORD
       If ErrClear Then 
          Function = -1
          Exit Function
       End If   
    End If   

    Function = 0   'return with no error
    
End Function



Function xlsWriteNumber(ByVal value#, ByVal lrow&, ByVal lcol&, ByVal CellFont&, ByVal CellAlignment&, ByVal HiddenLocked&, ByVal CellFormat&) As Long

    'convert the row, col from LONG to INTEGER.
    Row% = ConvertRow(lrow&)
    Col% = ConvertCol(lcol&)

    Dim NUMBER_RECORD As tNumber
    NUMBER_RECORD.opcode = 3
    NUMBER_RECORD.length = 15
    NUMBER_RECORD.Row = Row%
    NUMBER_RECORD.col = col%
    NUMBER_RECORD.rgbAttr1 = CByt(HiddenLocked&)
    NUMBER_RECORD.rgbAttr2 = CByt(CellFont& + CellFormat&)
    NUMBER_RECORD.rgbAttr3 = CByt(CellAlignment&)
    NUMBER_RECORD.NumberValue = value#

    If xlsBufferSize Then
       stat& = UpdateBuffer((NUMBER_RECORD))    
    Else
       Put #xlsFileNumber, , NUMBER_RECORD
       If ErrClear Then 
          Function = -1
          Exit Function
       End If   
    End If   

    Function = 0   'return with no error
    
End Function


Function xlsWriteText(value$, ByVal lrow&, ByVal lcol&, ByVal CellFont&, ByVal CellAlignment&, ByVal HiddenLocked&, ByVal CellFormat&) As Long

    'convert the row, col from LONG to INTEGER.
    Row% = ConvertRow(lrow&)
    Col% = ConvertCol(lcol&)

    Dim b As Byte
    st$ = value$
    l& = Len(st$)
    
    Dim TEXT_RECORD As 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 = Row%
    TEXT_RECORD.col = col%