Lead the data out to excel

Imports Microsoft.VisualBasic
Imports System.Text
Imports System.IO
Imports MainMod

Public Class ExcelFile
    Public Enum ValueTypes
        xlsInteger  =   0
        xlsNumber  =   1
        xlsText  =   2
    End Enum


    Public Enum CellAlignment
        xlsGeneralAlign  =   0
        xlsLeftAlign  =   1
        xlsCentreAlign  =   2
        xlsRightAlign  =   3
        xlsFillCell  =   4
        xlsLeftBorder  =   8
        xlsRightBorder  =   16
        xlsTopBorder  =   32
        xlsBottomBorder  =   64
        xlsShaded  =   128
    End Enum

    Public Enum CellFont

        xlsFont0  =   0
        xlsFont1  =   64
        xlsFont2  =   128
        xlsFont3  =   192
    End Enum

    Public Enum CellHiddenLocked
        xlsNormal  =   0
        xlsLocked  =   64
        xlsHidden  =   128
    End Enum

    Public Enum MarginTypes
        xlsLeftMargin  =   38
        xlsRightMargin  =   39
        xlsTopMargin  =   40
        xlsBottomMargin  =   41
    End Enum

    Public Enum FontFormatting
        xlsNoFormat  =   0
        xlsBold  =   1
        xlsItalic  =   2
        xlsUnderline  =   4
        xlsStrikeout  =   8
    End Enum

    Private Structure FONT_RECORD
        Dim opcode As Short
        Dim length As Short
        Dim FontHeight As Short
        Dim FontAttributes1 As Byte
        Dim FontAttributes2 As Byte
        Dim FontNameLength As Byte
    End Structure

    Private Structure PASSWORD_RECORD
        Dim opcode As Short
        Dim length As Short
    End Structure

    Private Structure HEADER_FOOTER_RECORD
        Dim opcode As Short
        Dim length As Short
        Dim TextLength As Byte
    End Structure

    Private Structure PROTECT_SPREADSHEET_RECORD
        Dim opcode As Short
        Dim length As Short
        Dim Protect As Short
    End Structure

    Private Structure FORMAT_COUNT_RECORD
        Dim opcode As Short
        Dim length As Short
        Dim Count As Short
    End Structure

    Private Structure FORMAT_RECORD
        Dim opcode As Short
        Dim length As Short
        Dim FormatLenght As Byte
    End Structure

    Private Structure COLWIDTH_RECORD
        Dim opcode As Short
        Dim length As Short
        Dim col1 As Byte
        Dim col2 As Byte
        Dim ColumnWidth As Short
    End Structure

    Private Structure BEG_FILE_RECORD
        Dim opcode As Short
        Dim length As Short
        Dim version As Short
        Dim ftype As Short
    End Structure

    Private Structure END_FILE_RECORD
        Dim opcode As Short
        Dim length As Short
    End Structure


    Private Structure PRINT_GRIDLINES_RECORD
        Dim opcode As Short
        Dim length As Short
        Dim PrintFlag As Short
    End Structure

    Private Structure tInteger
        Dim opcode As Short
        Dim length As Short
        Dim row As Short
        Dim col As Short
        Dim rgbAttr1 As Byte
        Dim rgbAttr2 As Byte
        Dim rgbAttr3 As Byte
        Dim intValue As Short
    End Structure


    Private Structure tNumber
        Dim opcode As Short
        Dim length As Short
        Dim row As Short
        Dim col As Short
        Dim rgbAttr1 As Byte
        Dim rgbAttr2 As Byte
        Dim rgbAttr3 As Byte
        Dim NumberValue As Double
    End Structure

    Private Structure tText
        Dim opcode As Short
        Dim length As Short
        Dim row As Short
        Dim col As Short
        Dim rgbAttr1 As Byte
        Dim rgbAttr2 As Byte
        Dim rgbAttr3 As Byte
        Dim TextLength As Byte
    End Structure

    Private Structure MARGIN_RECORD_LAYOUT
        Dim opcode As Short
        Dim length As Short
        Dim MarginValue As Double
    End Structure

    Private Structure HPAGE_BREAK_RECORD
        Dim opcode As Short
        Dim length As Short
        Dim NumPageBreaks As Short
    End Structure

    Private Structure DEF_ROWHEIGHT_RECORD
        Dim opcode As Integer
        Dim length As Integer
        Dim RowHeight As Integer
    End Structure

    Private Structure ROW_HEIGHT_RECORD
        Dim opcode As Integer
        Dim length As Integer
        Dim RowNumber As Integer
        Dim FirstColumn As Integer
        Dim LastColumn As Integer
        Dim RowHeight As Integer
        Dim internal As Integer
        Dim DefaultAttributes As Byte
        Dim FileOffset As Integer
        Dim rgbAttr1 As Byte
        Dim rgbAttr2 As Byte
        Dim rgbAttr3 As Byte
    End Structure

    Private Declare Sub CopyMemory Lib  " kernel32 "  Alias  " RtlMoveMemory "  (ByRef lpvDest As String, ByRef lpvSource As Short, ByVal cbCopy As Integer)

    Private m_shtFileNumber As Short
    Private m_udtBEG_FILE_MARKER As BEG_FILE_RECORD
    Private m_udtEND_FILE_MARKER As END_FILE_RECORD
    Private m_udtHORIZ_PAGE_BREAK As HPAGE_BREAK_RECORD

    Private m_shtHorizPageBreakRows() As Short
    Private m_shtNumHorizPageBreaks As Short



    Public WriteOnly Property PrintGridLines() As Boolean
        Set(ByVal Value As Boolean)
            Try
                Dim GRIDLINES_RECORD As PRINT_GRIDLINES_RECORD

                With GRIDLINES_RECORD
                    .opcode  =   43
                    .length  =   2
                    If Value  =  True Then
                        .PrintFlag  =   1
                    Else
                        .PrintFlag  =   0
                    End If

                End With

                FilePut(m_shtFileNumber, GRIDLINES_RECORD)
            Catch ex As Exception

            End Try
        End Set
    End Property

    Public WriteOnly Property ProtectSpreadsheet() As Boolean
        Set(ByVal Value As Boolean)
            Try
                Dim PROTECT_RECORD As PROTECT_SPREADSHEET_RECORD

                With PROTECT_RECORD
                    .opcode  =   18
                    .length  =   2
                    If Value  =  True Then
                        .Protect  =   1
                    Else
                        .Protect  =   0
                    End If

                End With

                FilePut(m_shtFileNumber, PROTECT_RECORD)

            Catch ex As Exception

            End Try
        End Set
    End Property

    Public Sub GetExeclFile(ByVal FileName As String, ByVal StrSql As String)
        Dim i As Integer  =   0 , j As Integer  =   0
        Dim Arr As Array  =  Nothing
        Dim Brr As Array  =  Nothing

        CreateFile(FileName)
        PrintGridLines  =  False

        SetMargin(ExcelFile.MarginTypes.xlsTopMargin,  1.5 )
        SetMargin(ExcelFile.MarginTypes.xlsLeftMargin,  1.5 )
        SetMargin(ExcelFile.MarginTypes.xlsRightMargin,  1.5 )
        SetMargin(ExcelFile.MarginTypes.xlsBottomMargin,  1.5 )
        SetFont( " Microsoft Sans Serif " ,  " 9 " , ExcelFile.FontFormatting.xlsItalic)
        SetColumnWidth( 1 ,  20 ,  9 )
        SetHeader( " This is the header " )
        SetFooter( " This ia the footer " )
        If StrSql  <>   ""  Then
            Arr  =  Split(StrSql, RECORD_SPLITOR)
            For i  =   0  To UBound(Arr)
                Brr  =  Split(Arr(i), FIELD_SPLITOR)
                For j  =   0  To UBound(Brr)
                    WriteValue(ExcelFile.ValueTypes.xlsText, ExcelFile.CellFont.xlsFont0, ExcelFile.CellAlignment.xlsCentreAlign, ExcelFile.CellHiddenLocked.xlsNormal, i  +   1 , j  +   1 , Brr(j))
                Next
            Next
        End If
        CloseFile()
    End Sub
    Public Function CreateFile(ByVal strFileName As String) As Integer
        Dim OpenFile As Integer

        Try
            If File.Exists(strFileName) Then
                File.SetAttributes(strFileName, FileAttributes.Normal)
                File.Delete(strFileName)
            End If

            m_shtFileNumber  =  FreeFile()
            'System.IO.File.Create(strFileName)

            FileOpen(m_shtFileNumber, strFileName, OpenMode.Binary)

            FilePut(m_shtFileNumber, m_udtBEG_FILE_MARKER)

            Call WriteDefaultFormats()

            ReDim m_shtHorizPageBreakRows( 0 )

            m_shtNumHorizPageBreaks  =   0

            OpenFile  =   0

        Catch ex As Exception
            OpenFile  =  Err.Number
        End Try

    End Function

    Public Function CloseFile() As Integer
        Dim x As Short

        Try
            If m_shtFileNumber  >   0  Then

                Dim lLoop1 As Integer
                Dim lLoop2 As Integer
                Dim lTemp As Integer
                If m_shtNumHorizPageBreaks  >   0  Then

                    For lLoop1  =  UBound(m_shtHorizPageBreakRows) To LBound(m_shtHorizPageBreakRows) Step  - 1
                        For lLoop2  =  LBound(m_shtHorizPageBreakRows)  +   1  To lLoop1
                            If m_shtHorizPageBreakRows(lLoop2  -   1 )  >  m_shtHorizPageBreakRows(lLoop2) Then
                                lTemp  =  m_shtHorizPageBreakRows(lLoop2  -   1 )
                                m_shtHorizPageBreakRows(lLoop2  -   1 )  =  m_shtHorizPageBreakRows(lLoop2)
                                m_shtHorizPageBreakRows(lLoop2)  =  lTemp
                            End If
                        Next lLoop2
                    Next lLoop1

                    With m_udtHORIZ_PAGE_BREAK
                        .opcode  =   27
                        .length  =   2   +  (m_shtNumHorizPageBreaks  *   2 )
                        .NumPageBreaks  =  m_shtNumHorizPageBreaks
                    End With

                    FilePut(m_shtFileNumber, m_udtHORIZ_PAGE_BREAK)

                    For x  =   1  To UBound(m_shtHorizPageBreakRows)
                        FilePut(m_shtFileNumber, MKI(m_shtHorizPageBreakRows(x)))
                    Next
                End If

                FilePut(m_shtFileNumber, m_udtEND_FILE_MARKER)
                FileClose(m_shtFileNumber)

                CloseFile  =   0
            Else
                CloseFile  =   - 1
            End If
        Catch ex As Exception
            CloseFile  =  Err.Number
        End Try

    End Function

    Private Sub Init()



        With m_udtBEG_FILE_MARKER
            .opcode  =   9
            .length  =   4
            .version  =   2
            .ftype  =   10
        End With

        With m_udtEND_FILE_MARKER
            .opcode  =   10
        End With

    End Sub

    Public Sub New()
        MyBase.New()

        Init()
    End Sub

    Public Function InsertHorizPageBreak(ByRef lrow As Integer) As Integer
        Dim row As Short

        Try

            If lrow  >   32767  Then
                row  =  CShort(lrow  -   65536 )
            Else
                row  =  CShort(lrow)  -   1
            End If

            m_shtNumHorizPageBreaks  =  m_shtNumHorizPageBreaks  +   1
            ReDim Preserve m_shtHorizPageBreakRows(m_shtNumHorizPageBreaks)

            m_shtHorizPageBreakRows(m_shtNumHorizPageBreaks)  =  row

        Catch ex As Exception
            InsertHorizPageBreak  =  Err.Number
        End Try

    End Function

    Public Function WriteValue(ByRef ValueType As ValueTypes, ByRef CellFontUsed As CellFont, ByRef Alignment As CellAlignment, ByRef HiddenLocked As CellHiddenLocked, ByRef lrow As Integer, ByRef lcol As Integer, ByRef Value As Object, Optional ByRef CellFormat As Integer  =   0 ) As Integer
        Dim l As Short
        Dim st As String
        Dim col As Short
        Dim row As Short

        Try

            Dim INTEGER_RECORD As tInteger
            Dim NUMBER_RECORD As tNumber
            Dim TEXT_RECORD As tText

            If lrow  >   32767  Then
                row  =  CShort(lrow  -   65536 )
            Else
                row  =  CShort(lrow)  -   1
            End If

            If lcol  >   32767  Then
                col  =  CShort(lcol  -   65536 )
            Else
                col  =  CShort(lcol)  -   1
            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)

                    With TEXT_RECORD
                        .opcode  =   4
                        .length  =   10

                        .TextLength  =  l


                        .length  =   8   +  l

                        .row  =  row
                        .col  =  col

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

                        FilePut(m_shtFileNumber, TEXT_RECORD)

                        FilePut(m_shtFileNumber, st)
                    End With

            End Select

            WriteValue  =   0
        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
            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

    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
            End With

            FilePut(m_shtFileNumber, COLWIDTH)

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

    Public Function SetFont(ByRef FontName As String, ByRef FontHeight As Short, ByRef FontFormat As FontFormatting) As Short
        Dim l As Short

        Try
            Dim FONTNAME_RECORD As FONT_RECORD

            l  =  GetLength(FontName)

            With FONTNAME_RECORD
                .opcode  =   49
                .length  =   5   +  l
                .FontHeight  =  FontHeight  *   20
                .FontAttributes1  =  CByte(FontFormat)
                .FontAttributes2  =  CByte( 0 )
                .FontNameLength  =  CByte(l)
            End With

            FilePut(m_shtFileNumber, FONTNAME_RECORD)


            FilePut(m_shtFileNumber, FontName)

            SetFont  =   0

        Catch ex As Exception
            SetFont  =  Err.Number
        End Try

    End Function

    Public Function SetHeader(ByRef HeaderText As String) As Integer
        Dim l As Short

        Try

            Dim HEADER_RECORD As HEADER_FOOTER_RECORD

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

            FilePut(m_shtFileNumber, HEADER_RECORD)

            FilePut(m_shtFileNumber, HeaderText)

            SetHeader  =   0

        Catch ex As Exception
            SetHeader  =  Err.Number
        End Try

    End Function

    Public Function SetFooter(ByRef FooterText As String) As Integer
        Dim l As Short

        Try
            Dim FOOTER_RECORD As HEADER_FOOTER_RECORD

            l  =  GetLength(FooterText)

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

            FilePut(m_shtFileNumber, FOOTER_RECORD)

            FilePut(m_shtFileNumber, FooterText)

            SetFooter  =   0

        Catch ex As Exception
            SetFooter  =  Err.Number
        End Try

    End Function

    Public Function SetFilePassword(ByRef PasswordText As String) As Integer
        Dim l As Short

        Try
            Dim FILE_PASSWORD_RECORD As PASSWORD_RECORD

            l  =  GetLength(PasswordText)

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

            FilePut(m_shtFileNumber, FILE_PASSWORD_RECORD)

            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)
            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
        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

    Public Function SetDefaultRowHeight(ByVal HeightValue As Integer) As Integer
        Try

            Dim DEFHEIGHT As DEF_ROWHEIGHT_RECORD

            With DEFHEIGHT
                .opcode  =   37
                .length  =   2
                .RowHeight  =  HeightValue  *   20
            End With

            FilePut(m_shtFileNumber, DEFHEIGHT)

            SetDefaultRowHeight  =   0

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

    Public Function SetRowHeight(ByVal Row As Integer, ByVal HeightValue As Short) As Integer

        Dim o_intRow As Integer

        Try

            If Row  >   32767  Then
                o_intRow  =  CInt(Row  -   65536 )
            Else
                o_intRow  =  CInt(Row)  -   1
            End If

            Dim ROWHEIGHTREC As ROW_HEIGHT_RECORD

            With ROWHEIGHTREC
                .opcode  =   8
                .length  =   16
                .RowNumber  =  o_intRow
                .FirstColumn  =   0
                .LastColumn  =   256
                .RowHeight  =  HeightValue  *   20
                .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

转载于:https://www.cnblogs.com/jiemupig/archive/2006/05/30/413086.html