excelfile.cls

VB 不需要安装 EXECEL 直接操作 XLS 文档 的类

           .rgbAttr3 = CByte(Alignment)
           .NumberValue = CDbl(value)
         End With
         Put #FileNumber, , NUMBER_RECORD
      
      
      Case ValueTypes.xlsText
         Dim b As Byte
         st$ = CStr(value)
         l% = Len(st$)
        
        Dim TEXT_RECORD As tText
        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
          Put #FileNumber, , TEXT_RECORD
        
          'Then the actual string data
          For a = 1 To l%
             b = Asc(Mid$(st$, a, 1))
             Put #FileNumber, , b
          Next
        End With
      
    End Select
    
    WriteValue = 0   'return with no error
    
Exit Function

Write_Error:
    WriteValue = Err.Number
    Exit Function

End Function


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

On Error GoTo Write_Error

    '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
    Put #FileNumber, , MarginRecord

    SetMargin = 0
    
Exit Function

Write_Error:
    SetMargin = Err.Number
    Exit Function

End Function


Public Function SetColumnWidth(FirstColumn As Byte, LastColumn As Byte, WidthValue As Integer)

On Error GoTo Write_Error

    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
    Put #FileNumber, , COLWIDTH

    SetColumnWidth = 0
    
Exit Function

Write_Error:
    SetColumnWidth = Err.Number
    Exit Function

End Function


Public Function SetFont(FontName As String, FontHeight As Integer, FontFormat As FontFormatting) As Integer

On Error GoTo Write_Error

    '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)
    
    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(Len(FontName))
    End With
    Put #FileNumber, , FONTNAME_RECORD

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

    SetFont = 0
    
Exit Function

Write_Error:
    SetFont = Err.Number
    Exit Function


End Function


Public Function SetHeader(HeaderText As String) As Integer

On Error GoTo Write_Error

    Dim HEADER_RECORD As HEADER_FOOTER_RECORD
    
    l% = Len(HeaderText)
    
    With HEADER_RECORD
      .opcode = 20
      .length = 1 + l%
      .TextLength = CByte(Len(HeaderText))
    End With
    Put #FileNumber, , HEADER_RECORD

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

    SetHeader = 0
    
Exit Function

Write_Error:
    SetHeader = Err.Number
    Exit Function

End Function



Public Function SetFooter(FooterText As String) As Integer

On Error GoTo Write_Error

    Dim FOOTER_RECORD As HEADER_FOOTER_RECORD
    
    l% = Len(FooterText)
    
    With FOOTER_RECORD
      .opcode = 21
      .length = 1 + l%
      .TextLength = CByte(Len(FooterText))
    End With
    Put #FileNumber, , FOOTER_RECORD

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

    SetFooter = 0
    
Exit Function

Write_Error:
    SetFooter = Err.Number
    Exit Function

End Function



Public Function SetFilePassword(PasswordText As String) As Integer

On Error GoTo Write_Error

    Dim FILE_PASSWORD_RECORD As PASSWORD_RECORD
    
    l% = Len(PasswordText)
    
    With FILE_PASSWORD_RECORD
      .opcode = 47
      .length = l%
    End With
    Put #FileNumber, , FILE_PASSWORD_RECORD

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

    SetFilePassword = 0
    
Exit Function

Write_Error:
    SetFilePassword = Err.Number
    Exit Function

End Function




Public Property Let PrintGridLines(ByVal newvalue As Boolean)

On Error GoTo Write_Error

    Dim GRIDLINES_RECORD As PRINT_GRIDLINES_RECORD
    
    With GRIDLINES_RECORD
      .opcode = 43
      .length = 2
      If newvalue = True Then
        .PrintFlag = 1
      Else
        .PrintFlag = 0
      End If
      
    End With
    Put #FileNumber, , GRIDLINES_RECORD

Exit Property

Write_Error:
    Exit Property

  
End Property




Public Property Let ProtectSpreadsheet(ByVal newvalue As Boolean)

On Error GoTo Write_Error

    Dim PROTECT_RECORD As PROTECT_SPREADSHEET_RECORD
    
    With PROTECT_RECORD
      .opcode = 18
      .length = 2
      If newvalue = True Then
        .Protect = 1
      Else
        .Protect = 0
      End If
      
    End With
    Put #FileNumber, , PROTECT_RECORD

Exit Property

Write_Error:
    Exit Property

  
End Property


Public Function WriteDefaultFormats() As Integer
    
    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) = "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 = &H1F
        .length = &H2
        .Count = CInt(UBound(aFormat))
    End With
    Put #FileNumber, , cFORMAT_COUNT_RECORD

    For lIndex = LBound(aFormat) To UBound(aFormat)
        l = Len(aFormat(lIndex))
        With cFORMAT_RECORD
          .opcode = &H1E
          .length = CInt(l + 1)
          .FormatLenght = CInt(l)
        End With
        Put #FileNumber, , cFORMAT_RECORD
    
        'Then the actual format
        Dim b As Byte, a As Long
        For a = 1 To l
           b = Asc(Mid$(aFormat(lIndex), a, 1))
           Put #FileNumber, , b
        Next
    Next lIndex
    
Exit Function

End Function


Function MKI$(x As Integer)
   'used for writing integer array values to the disk file
   temp$ = Space$(2)
   CopyMemory ByVal temp$, x%, 2
   MKI$ = temp$
End Function


Public Function SetDefaultRowHeight(HeightValue As Integer)

On Error GoTo Write_Error

'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
    Put #FileNumber, , DEFHEIGHT

    SetDefaultRowHeight = 0
    
Exit Function

Write_Error:
    SetDefaultRowHeight = Err.Number
    Exit Function

End Function


Public Function SetRowHeight(lrow As Long, HeightValue As Integer)

On Error GoTo Write_Error

'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
        

'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 = Row%
      .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
    Put #FileNumber, , ROWHEIGHTREC

    SetRowHeight = 0
    
Exit Function

Write_Error:
    SetRowHeight = Err.Number
    Exit Function

End Function