excel.inc

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

    TEXT_RECORD.rgbAttr1 = CByt(HiddenLocked&)
    TEXT_RECORD.rgbAttr2 = CByt(CellFont& + CellFormat&)
    TEXT_RECORD.rgbAttr3 = CByt(CellAlignment&)
    
    'Put record header
    If xlsBufferSize Then
       stat& = UpdateBuffer((TEXT_RECORD))    
    Else
       Put #xlsFileNumber, , TEXT_RECORD
    End If   
    
    'Then the actual string data
    For a& = 1 To l&
        b = Asc(Mid$(st$, a&, 1))
        If xlsBufferSize Then
           stat& = UpdateBuffer(MkByt$(b))    
        Else
           Put #xlsFileNumber, , b
           If ErrClear Then 
              Function = -1
              Exit Function
           End If   
        End If   
    Next


    Function = 0   'return with no error
    
End Function


Function xlsWriteDate(DateString$, 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&)
    
    'convert the DateString$ from YYYYMMDD to a Julian date number
    value&= (DateToJulian&(DateString$) - DateToJulian&("19000100")) + 1
    
    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 = CDbl(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 xlsSetMargin(ByVal Margin&, ByVal MarginValue#) As Long

    'write the spreadsheet's layout information (in inches)
    Dim MARGINRECORD As 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 Then
        stat& = UpdateBuffer((MARGINRECORD))    
    Else
        Put #xlsFileNumber, , MARGINRECORD
        If ErrClear Then 
           Function = -1
           Exit Function
        End If   
    End If    

    Function = 0
    
End Function


Function xlsSetColumnWidth(ByVal FirstColumn&, ByVal LastColumn&, ByVal WidthValue&) As Long

    Dim COLWIDTH As COLWIDTH_RECORD
    COLWIDTH.opcode = 36
    COLWIDTH.length = 4
    COLWIDTH.col1 = CByt(FirstColumn&) - 1
    COLWIDTH.col2 = CByt(LastColumn&) - 1
    COLWIDTH.ColumnWidth = WidthValue& * 256  'values are specified as 1/256 of a character

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

    Function = 0
    
End Function



Function xlsSetFont(FontName$, ByVal FontHeight&, ByVal FontFormat&) As Long

    '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)
    
    Dim FONTNAME_RECORD As FONT_RECORD
    
    l& = Len(FontName$)
    
    FONTNAME_RECORD.opcode = 49
    FONTNAME_RECORD.length = 5 + l&
    FONTNAME_RECORD.FontHeight = FontHeight& * 20
    FONTNAME_RECORD.FontAttributes1 = CByt(FontFormat&)  'bold/underline etc...
    FONTNAME_RECORD.FontAttributes2 = CByt(0)            'reserved-always zero!!
    FONTNAME_RECORD.FontNameLength = CByt(l&)

    If xlsBufferSize Then
        stat& = UpdateBuffer((FONTNAME_RECORD))    
    Else
        Put #xlsFileNumber, , FONTNAME_RECORD
    End If    

    'Then the actual font name data
    Dim b As Byte
    For a& = 1 To l&
       b = Asc(Mid$(FontName$, a&, 1))
       If xlsBufferSize Then
           stat& = UpdateBuffer(MkByt$(b))    
       Else
           Put #xlsFileNumber, , b
           If ErrClear Then 
              Function = -1
              Exit Function
           End If   
       End If    
    Next

    Function = 0
    
End Function



Function xlsSetHeader(HeaderText$) As Long

    Dim HEADER_RECORD As HEADER_FOOTER_RECORD
    
    l& = Len(HeaderText$)
    
    HEADER_RECORD.opcode = 20
    HEADER_RECORD.length = 1 + l&
    HEADER_RECORD.TextLength = CByt(l&)

    If xlsBufferSize Then
       stat& = UpdateBuffer((HEADER_RECORD))    
    Else
       Put #xlsFileNumber, , HEADER_RECORD
    End If   

    'Then the actual Header text
    Dim b As Byte
    For a& = 1 To l&
       b = Asc(Mid$(HeaderText$, a&, 1))
       If xlsBufferSize Then
          stat& = UpdateBuffer(MkByt$(b))    
       Else
          Put #xlsFileNumber, , b
          If ErrClear Then 
             Function = -1
             Exit Function
          End If   
       End If   
    Next


    Function = 0

End Function



Function xlsSetFooter(FooterText$) As Long

    Dim FOOTER_RECORD As HEADER_FOOTER_RECORD
    
    l& = Len(FooterText$)
    
    FOOTER_RECORD.opcode = 21
    FOOTER_RECORD.length = 1 + l&
    FOOTER_RECORD.TextLength = CByt(l&)

    If xlsBufferSize Then
       stat& = UpdateBuffer((FOOTER_RECORD))    
    Else
       Put #xlsFileNumber, , FOOTER_RECORD
    End If   

    'Then the actual Header text
    Dim b As Byte
    For a& = 1 To l&
       b = Asc(Mid$(FooterText$, a&, 1))
       If xlsBufferSize Then
          stat& = UpdateBuffer(MkByt$(b))    
       Else
          Put #xlsFileNumber, , b
          If ErrClear Then 
             Function = -1
             Exit Function
          End If   
       End If   
    Next

    Function = 0
    
End Function



Function xlsSetFilePassword(PasswordText$) As Long

    Dim FILE_PASSWORD_RECORD As PASSWORD_RECORD
    
    l& = Len(PasswordText$)
    
    FILE_PASSWORD_RECORD.opcode = 47
    FILE_PASSWORD_RECORD.length = l&

    If xlsBufferSize Then
       stat& = UpdateBuffer((FILE_PASSWORD_RECORD))    
    Else
       Put #xlsFileNumber, , FILE_PASSWORD_RECORD
    End If   

    'Then the actual Password text
    Dim b As Byte
    For a& = 1 To l&
       b = Asc(Mid$(PasswordText$, a&, 1))
       If xlsBufferSize Then
          stat& = UpdateBuffer(MkByt$(b))    
       Else
          Put #xlsFileNumber, , b
          If ErrClear Then 
             Function = -1
             Exit Function
          End If   
       End If   
    Next

    Function = 0
    
End Function




Function xlsPrintGridLines(ByVal TrueFalse&) As Long

    Dim GRIDLINES_RECORD As PRINT_GRIDLINES_RECORD
    
    GRIDLINES_RECORD.opcode = 43
    GRIDLINES_RECORD.length = 2
    
    If TrueFalse& = 0 Then
       GRIDLINES_RECORD.PrintFlag = 0
    Else
       GRIDLINES_RECORD.PrintFlag = 1
    End If
      
    If xlsBufferSize Then
       stat& = UpdateBuffer((GRIDLINES_RECORD))    
    Else
       Put #xlsFileNumber, , GRIDLINES_RECORD
    
       If ErrClear Then 
          Function = -1
          Exit Function
       End If   
    End If   
    
    Function = 0
    
End Function




Function xlsProtectSpreadsheet(ByVal TrueFalse&) As Long

    Dim PROTECT_RECORD As PROTECT_SPREADSHEET_RECORD
    
    PROTECT_RECORD.opcode = 18
    PROTECT_RECORD.length = 2
    
    If TrueFalse& = 0 Then
       PROTECT_RECORD.Protect = 0
    Else
       PROTECT_RECORD.Protect = 1
    End If
      
    If xlsBufferSize Then
       stat& = UpdateBuffer((PROTECT_RECORD))    
    Else
       Put #xlsFileNumber, , PROTECT_RECORD

       If ErrClear Then 
          Function = -1
          Exit Function
       End If   
    End If   
    
    Function = 0
  
End Function


Function xlsWriteDefaultFormats() As Long
    
    Dim cFORMAT_COUNT_RECORD As FORMAT_COUNT_RECORD
    Dim cFORMAT_RECORD As FORMAT_RECORD
    Dim lIndex As Long
    Dim aFormat(0 To 23) As String
    Dim l As Long
    Dim q As String
    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 = &H1F
    cFORMAT_COUNT_RECORD.length = &H2
    cFORMAT_COUNT_RECORD.Count = CInt(UBound(aFormat))

    If xlsBufferSize Then
       stat& = UpdateBuffer((cFORMAT_COUNT_RECORD))    
    Else
       Put #xlsFileNumber, , cFORMAT_COUNT_RECORD
    End If
    
    For lIndex = LBound(aFormat) To UBound(aFormat)
        l = Len(aFormat(lIndex))

        cFORMAT_RECORD.opcode = &H1E
        cFORMAT_RECORD.length = l + 1
        cFORMAT_RECORD.FormatLength = l

        If xlsBufferSize Then
           stat& = UpdateBuffer((cFORMAT_RECORD))    
        Else
           Put #xlsFileNumber, , cFORMAT_RECORD
        End If   
    
        'Then the actual format
        Dim b As Byte, a As Long
        For a = 1 To l
           b = Asc(Mid$(aFormat(lIndex), a, 1))
           If xlsBufferSize Then
              stat& = UpdateBuffer(MkByt$(b))    
           Else
              Put #xlsFileNumber, , b
              If ErrClear Then 
                 Function = -1
                 Exit Function
              End If   
           End If   
        Next
    Next 

    Function = 0
        
End Function



Function xlsSetDefaultRowHeight(ByVal HeightValue&) As Long

'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.

    Dim DEFHEIGHT As DEF_ROWHEIGHT_RECORD
    DEFHEIGHT.opcode = 37
    DEFHEIGHT.length = 2
    DEFHEIGHT.RowHeight = HeightValue& * 20  'convert points to 1/20ths of point

    If xlsBufferSize Then
       stat& = UpdateBuffer((DEFHEIGHT))    
    Else
       Put #xlsFileNumber, , DEFHEIGHT

       If ErrClear Then 
          Function = -1
          Exit Function
       End If   
    End If   

    Function = 0

End Function


Function xlsSetRowHeight(ByVal lrow&, ByVal HeightValue&) As Long

    'convert the row, col from LONG to INTEGER.
    Row% = 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.

    Dim ROWHEIGHTREC As 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 Then
       stat& = UpdateBuffer((ROWHEIGHTREC))    
    Else
       Put #xlsFileNumber, , ROWHEIGHTREC

       If ErrClear Then 
          Function = -1
          Exit Function
       End If   
    End If   

    Function = 0

End Function


Function DateToJulian&(DateString$) As Long

  'DateString$ must be in YYYYMMDD
  
  Local Elapsed As Long
  
  If Len(DateString$) <> 8 Then
     Function = 0
     Exit Function
  End If   

  Year& = Val(Left$(DateString$, 4))
  month& = Val(Mid$(DateString$, 5, 2))
  day& = Val(Right$(DateString$, 2))
  
  If month& < 3 Then                      ' January or February?
     month& = month& + 12                   ' 13th or 14th month ....
     Decr year&                            ' .... of prev. year
  End If
  
  Elapsed = Int((year& + 4712) * 365.25)  ' years elapsed
  Elapsed = Elapsed - (year& \ 100)       ' substract century leapdays
  Elapsed = Elapsed + (year& \ 400)       ' re-add valid ones
  Elapsed = Elapsed + _
            Int(30.6 * (month& - 1) + .2) ' months elapsed + adjustm.
  Function = Elapsed + day&               ' days of final month

End Function



Function CTOD$(PBDate As String) 
'いいいいいいいいいいいいいいいいいいいいいいいいいいいいいいい