cexcelfile.vb

生成Excel文件.Visual Basic 2005 代码.包含一个类.

        Dim l As Short
        Dim st As String
        Dim col As Short
        Dim row As Short

        Try
            'the row and column values are written to the excel file as
            'unsigned integers. Therefore, must convert the longs to integer.

            Dim INTEGER_RECORD As tInteger
            Dim NUMBER_RECORD As tNumber
            'Dim b As Byte
            Dim TEXT_RECORD As tText

            If lrow > 32767 Then
                row = CShort(lrow - 65536)
            Else
                row = CShort(lrow) - 1 'rows/cols in Excel binary file are zero based
            End If

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

            Select Case ValueType
                Case ValueTypes.xlsInteger
                    With INTEGER_RECORD
                        .opcode = 2
                        .length = 9
                        .row = row
                        .col = col
                        .rgbAttr1 = CByte(HiddenLocked)
                        .rgbAttr2 = CByte(CellFontUsed + CellFormat)
                        .rgbAttr3 = CByte(Alignment)
                        .intValue = CShort(Value)
                    End With

                    FilePut(m_shtFileNumber, INTEGER_RECORD)

                Case ValueTypes.xlsNumber
                    With NUMBER_RECORD
                        .opcode = 3
                        .length = 15
                        .row = row
                        .col = col
                        .rgbAttr1 = CByte(HiddenLocked)
                        .rgbAttr2 = CByte(CellFontUsed + CellFormat)
                        .rgbAttr3 = CByte(Alignment)
                        .NumberValue = CDbl(Value)
                    End With

                    FilePut(m_shtFileNumber, NUMBER_RECORD)

                Case ValueTypes.xlsText
                    st = CType(Value, String)

                    l = GetLength(st) 'LenB(StrConv(st, vbFromUnicode)) 'Len(st$)

                    With TEXT_RECORD
                        .opcode = 4
                        .length = 10
                        'Length of the text portion of the record
                        .TextLength = l

                        'Total length of the record
                        .length = 8 + l

                        .row = row
                        .col = col

                        .rgbAttr1 = CByte(HiddenLocked)
                        .rgbAttr2 = CByte(CellFontUsed + CellFormat)
                        .rgbAttr3 = CByte(Alignment)

                        'Put record header
                        FilePut(m_shtFileNumber, TEXT_RECORD)

                        'Then the actual string data
                        'For a = 1 To l%
                        '   b = Asc(Mid$(st$, a, 1))
                        '   Put #m_shtFileNumber, , b
                        'Next

                        FilePut(m_shtFileNumber, st)
                    End With

            End Select

            WriteValue = 0 'return with no error
        Catch ex As Exception
            WriteValue = Err.Number
        End Try

    End Function

    Public Function SetMargin(ByRef Margin As MarginTypes, ByRef MarginValue As Double) As Integer

        Try
            'write the spreadsheet's layout information (in inches)
            Dim MarginRecord As MARGIN_RECORD_LAYOUT

            With MarginRecord
                .opcode = Margin
                .length = 8
                .MarginValue = MarginValue 'in inches
            End With

            FilePut(m_shtFileNumber, MarginRecord)

            SetMargin = 0

        Catch ex As Exception
            SetMargin = Err.Number
        End Try

    End Function

    ''' <summary>
    ''' 设置Excel列宽度。
    ''' </summary>
    ''' <param name="FirstColumn">起始列</param>
    ''' <param name="LastColumn">终止列。</param>
    ''' <param name="WidthValue">列宽。</param>
    Public Function SetColumnWidth(ByRef FirstColumn As Byte, ByRef LastColumn As Byte, ByRef WidthValue As Short) As Integer
        Try
            Dim COLWIDTH As COLWIDTH_RECORD

            With COLWIDTH
                .opcode = 36
                .length = 4
                .col1 = FirstColumn - 1
                .col2 = LastColumn - 1
                .ColumnWidth = WidthValue * 256 'values are specified as 1/256 of a character
            End With

            FilePut(m_shtFileNumber, COLWIDTH)

            SetColumnWidth = 0
        Catch ex As Exception
            SetColumnWidth = Err.Number
        End Try
    End Function

    ''' <summary>
    ''' 设置单元格字体格式。
    ''' </summary>
    ''' <param name="FontName">字体名称。</param>
    ''' <param name="FontHeight">字体大小。</param>
    ''' <param name="FontFormat">字体格式。</param>
    Public Function SetFont(ByRef FontName As String, ByRef FontHeight As Short, ByRef FontFormat As FontFormatting) As Short
        Dim l As Short

        Try
            '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 = GetLength(FontName) 'LenB(StrConv(FontName, vbFromUnicode)) 'Len(FontName)

            With FONTNAME_RECORD
                .opcode = 49
                .length = 5 + l
                .FontHeight = FontHeight * 20
                .FontAttributes1 = CByte(FontFormat) 'bold/underline etc...
                .FontAttributes2 = CByte(0) 'reserved-always zero!!
                .FontNameLength = CByte(l) 'CByte(Len(FontName))
            End With

            FilePut(m_shtFileNumber, FONTNAME_RECORD)

            'Then the actual font name data
            'Dim b As Byte
            'For a = 1 To l%
            '   b = Asc(Mid$(FontName, a, 1))
            '   Put #m_shtFileNumber, , b
            'Next

            FilePut(m_shtFileNumber, FontName)

            SetFont = 0

        Catch ex As Exception
            SetFont = Err.Number
        End Try

    End Function

    ''' <summary>
    ''' 设置页眉。
    ''' </summary>
    ''' <param name="HeaderText">页眉文字。</param>
    Public Function SetHeader(ByRef HeaderText As String) As Integer
        Dim l As Short

        Try

            Dim HEADER_RECORD As HEADER_FOOTER_RECORD

            l = GetLength(HeaderText)   'LenB(StrConv(HeaderText, vbFromUnicode)) 'Len(HeaderText)

            With HEADER_RECORD
                .opcode = 20
                .length = 1 + l
                .TextLength = CByte(l) 'CByte(Len(HeaderText))
            End With

            FilePut(m_shtFileNumber, HEADER_RECORD)

            'Then the actual Header text
            'Dim b As Byte
            'For a = 1 To l%
            '   b = Asc(Mid$(HeaderText, a, 1))
            '   Put #m_shtFileNumber, , b
            'Next

            FilePut(m_shtFileNumber, HeaderText)

            SetHeader = 0

        Catch ex As Exception
            SetHeader = Err.Number
        End Try

    End Function

    ''' <summary>
    ''' 设置页脚。
    ''' </summary>
    ''' <param name="FooterText">页脚文字。</param>
    Public Function SetFooter(ByRef FooterText As String) As Integer
        Dim l As Short

        Try
            Dim FOOTER_RECORD As HEADER_FOOTER_RECORD

            l = GetLength(FooterText) 'LenB(StrConv(FooterText, vbFromUnicode)) 'Len(FooterText)

            With FOOTER_RECORD
                .opcode = 21
                .length = 1 + l
                .TextLength = CByte(l) 'CByte(Len(FooterText))
            End With

            FilePut(m_shtFileNumber, FOOTER_RECORD)

            'Then the actual Header text
            'Dim b As Byte
            'For a = 1 To l%
            '   b = Asc(Mid$(FooterText, a, 1))
            '   Put #m_shtFileNumber, , b
            'Next

            FilePut(m_shtFileNumber, FooterText)

            SetFooter = 0

        Catch ex As Exception
            SetFooter = Err.Number
        End Try

    End Function

    ''' <summary>
    ''' 设置文件密码。
    ''' </summary>
    ''' <param name="PasswordText">密码。</param>
    Public Function SetFilePassword(ByRef PasswordText As String) As Integer
        Dim l As Short

        Try
            Dim FILE_PASSWORD_RECORD As PASSWORD_RECORD

            l = GetLength(PasswordText) 'LenB(StrConv(PasswordText, vbFromUnicode)) 'Len(PasswordText)

            With FILE_PASSWORD_RECORD
                .opcode = 47
                .length = l
            End With

            FilePut(m_shtFileNumber, FILE_PASSWORD_RECORD)

            'Then the actual Password text
            'Dim b As Byte
            'For a = 1 To l%
            '   b = Asc(Mid$(PasswordText, a, 1))
            '   Put #m_shtFileNumber, , b
            'Next

            FilePut(m_shtFileNumber, PasswordText)

            SetFilePassword = 0

        Catch ex As Exception
            SetFilePassword = Err.Number
        End Try

    End Function

    Private Function WriteDefaultFormats() As Integer

        Dim cFORMAT_COUNT_RECORD As FORMAT_COUNT_RECORD
        Dim cFORMAT_RECORD As FORMAT_RECORD
        Dim lIndex As Integer
        Dim aFormat(23) As String
        Dim l As Integer
        Dim q As String = 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) = "dd/mm/yy"
        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) = "@"

        With cFORMAT_COUNT_RECORD
            .opcode = &H1FS
            .length = &H2S
            .Count = CShort(UBound(aFormat))
        End With

        FilePut(m_shtFileNumber, cFORMAT_COUNT_RECORD)

        Dim b As Byte
        Dim a As Integer
        For lIndex = LBound(aFormat) To UBound(aFormat)
            l = Len(aFormat(lIndex))
            With cFORMAT_RECORD
                .opcode = &H1ES
                .length = CShort(l + 1)
                .FormatLenght = CShort(l)
            End With

            FilePut(m_shtFileNumber, cFORMAT_RECORD)

            'Then the actual format
            For a = 1 To l
                b = Asc(Mid(aFormat(lIndex), a, 1))
                FilePut(m_shtFileNumber, b)
            Next
        Next lIndex

    End Function

    Private Function MKI(ByRef x As Short) As String
        Dim temp As String
        'used for writing integer array values to the disk file
        temp = Space(2)
        CopyMemory(temp, x, 2)
        MKI = temp
    End Function

    Private Function GetLength(ByVal strText As String) As Integer
        Return Encoding.Default.GetBytes(strText).Length
    End Function

    ''' <summary>
    ''' 设置行的默认高度。
    ''' </summary>
    ''' <param name="HeightValue">行高。</param>
    Public Function SetDefaultRowHeight(ByVal HeightValue As Integer) As Integer
        Try
            '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

            With DEFHEIGHT
                .opcode = 37
                .length = 2
                .RowHeight = HeightValue * 20  'convert points to 1/20ths of point
            End With

            FilePut(m_shtFileNumber, DEFHEIGHT)

            SetDefaultRowHeight = 0

        Catch ex As Exception
            SetDefaultRowHeight = Err.Number
        End Try
    End Function

    ''' <summary>
    ''' 设置行高。
    ''' </summary>
    ''' <param name="Row">指定的行号。</param>
    ''' <param name="HeightValue">行高值。</param>
    Public Function SetRowHeight(ByVal Row As Integer, ByVal HeightValue As Short) As Integer

        Dim o_intRow As Integer

        Try
            'the row and column values are written to the excel file as
            'unsigned integers. Therefore, must convert the longs to integer.

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

            '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

            With ROWHEIGHTREC
                .opcode = 8
                .length = 16
                .RowNumber = o_intRow
                .FirstColumn = 0
                .LastColumn = 256
                .RowHeight = HeightValue * 20 'convert points to 1/20ths of point
                .internal = 0
                .DefaultAttributes = 0
                .FileOffset = 0
                .rgbAttr1 = 0
                .rgbAttr2 = 0
                .rgbAttr3 = 0
            End With

            FilePut(m_shtFileNumber, ROWHEIGHTREC)

            SetRowHeight = 0

        Catch ex As Exception
            SetRowHeight = Err.Number
        End Try
    End Function

End Class