怎样通过vb 程序生成excel文件？

Question

some code FYI
Private Function lpExportToExcel(rstExport as adodb.recordset) As 
Boolean
Dim intInc As Integer
Dim lngColInc As Integer'Create a new workbook in Excel
Dim oExcel As New Excel.Application
Dim oBook As New Excel.Workbook
Dim oSheet As New Excel.Worksheet  'Set oExcel = CreateObject("Excel.Application")
  Set oBook = oExcel.Workbooks.Add
  Set oSheet = oBook.Worksheets(1)  'Transfer the data to Excel
  Dim strRange As String
  Dim intStartRange As Integer  intStartRange = 65  For lngColInc = 0 To rstExport.Fields.Count - 1
    strRange = Chr(intStartRange) & Trim(str(1))
    oSheet.Range(strRange) = rstExport.Fields(lngColInc).name
    intStartRange = intStartRange + 1    If lngColInc = 25 Then Exit For
  Next lngColInc  oSheet.Range("A1", strRange).Font.Bold = True
  oSheet.Range("A1", strRange).Font.Color = vbBlue  oSheet.Range("A2").CopyFromRecordset rstExport  cdgSql.DialogTitle = "Save this result to "
  cdgSql.ShowSave
  'Save the Workbook and Quit Excel  oBook.SaveAs cdgSql.FileName
  oExcel.Quit  lpExportToExcel = True
End Function

Answer 1

Sub SaveAsExcel(ByVal rs As DAO.Recordset, ByVal filename _
 As String, Optional Ffmt As XlFileFormat = xlWorkbookNormal, _
 Optional bHeaders As Boolean = True)
 '***********************************************************
 ' Marko Hernandez
 ' Dec. 2, 2000
 '
 ' Exports a Recordset data into a Microsoft Excel Sheet and
 'then can save as new file
 ' with a given format such Lotus, Q-Pro, dBase, Text
 '
 ' Arguments:
 '
 ' rs : Recordset object (DAO) containing data.
 ' filename: Name of the file.
 ' Ffmt: File Format the default value is the
  'MS-Excel current version.
 ' bHeaders: If true the name of the fields will be inserted
 'in the first row of each column.
 '
 
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet'Field object
Dim fd As Field'Cell count, the cells we can use
Dim CellCnt As Integer'File Extension Type
Dim Fet As String Screen.MousePointer = vbHourglass
' Assign object references to the variables. Use
' Add methods to create new workbook and worksheet
' objects.
Set xlApp = New Excel.Application
Set xlBook = xlApp.Workbooks.Add
Set xlSheet = xlBook.Worksheets.Add'Get the field names
If bHeaders Then
     CellCnt = 1
     For Each fd In rs.Fields
        Select Case fd.Type
        Case dbBinary, dbGUID, dbLongBinary, dbVarBinary
            ' This type of data can't export to excel
        Case Else
            xlSheet.Cells(1, CellCnt).Value = fd.Name
            xlSheet.Cells(1, CellCnt).Interior.ColorIndex = 33
            xlSheet.Cells(1, CellCnt).Font.Bold = True
            xlSheet.Cells(1, CellCnt).BorderAround xlContinuous
            CellCnt = CellCnt + 1
        End Select
     Next
End If'Rewind the rescordset
rs.MoveFirst
i = 2
Do While Not rs.EOF()
     CellCnt = 1
     For Each fd In rs.Fields
        Select Case fd.Type
        Case dbBinary, dbGUID, dbLongBinary, dbVarBinary
            ' This type of data can't export to excel
        Case Else
            xlSheet.Cells(i, CellCnt).Value = _
                rs.Fields(fd.Name).Value
            'xlSheet.Columns().AutoFit
            CellCnt = CellCnt + 1
        End Select
     Next
     rs.MoveNext
     i = i + 1
 Loop'Fit all columns
CellCnt = 1
For Each fd In rs.Fields     Select Case fd.Type
         Case dbBinary, dbGUID, dbLongBinary, _
                 dbVarBinary
                  ' This type of data can't export to excel
          Case Else
                  xlSheet.Columns(CellCnt).AutoFit
                  CellCnt = CellCnt + 1
          End Select
Next'Get the file extension
Select Case Ffmt
     Case xlSYLK
         Fet = "slk"
     Case xlWKS
         Fet = "wks"
     Case xlWK1, xlWK1ALL, xlWK1FMT
         Fet = "wk1"
     Case xlCSV, xlCSVMac, xlCSVdos, xlCSVWindows
         Fet = "csv"
     Case xlDBF2, xlDBF3, xlDBF4
         Fet = "dbf"
     Case xlWorkbookNormal, xlExcel2FarEast, xlExcel3, _
         xlExcel4, xlExcel4Workbook, xlExcel5, xlExcel6, _
         xlExcel7, xlExcel9795
         Fet = "xls"
     Case xlHTML
         Fet = "htm"
     Case xlTextMac, xlTextdos, xlTextWindows, xlUnicodeText, _
           xlCurrentPlatformText
         Fet = "txt"
     Case xlTextPrinter
         Fet = "prn"
     Case Else
         Fet = "dat"
 End Select
     
' Save the Worksheet.
If InStr(1, filename, ".") = 0 Then filename = _
   filename + "." + Fet
xlSheet.SaveAs filename, Ffmt' Close the Workbook
xlBook.Close
' Close Microsoft Excel with the Quit method.
xlApp.Quit' Release the objects.
Set xlApp = Nothing
Set xlBook = Nothing
Set xlSheet = NothingScreen.MousePointer = vbDefault
End Sub
''*******************SAMPLE USAGE BELOW***********************
'Private Sub Command1_Click()
' SaveAsExcel Data1.Recordset.Clone(), Text1.Text, _
'    Combo1.ItemData(Combo1.ListIndex)
'End SubPrivate Sub Form_Load()
'
' Text1.Text = "C:\New File"
' Combo1.AddItem "Installed Excel Format"
' Combo1.ItemData(Combo1.NewIndex) = xlWorkbookNormal
' Combo1.AddItem "Comma Separated Text"
' Combo1.ItemData(Combo1.NewIndex) = xlCSV
' Combo1.AddItem "Excel 95/97"
' Combo1.ItemData(Combo1.NewIndex) = xlExcel9795
' Combo1.AddItem "Internet Format (HTML)"
' Combo1.ItemData(Combo1.NewIndex) = xlHtml
' Combo1.AddItem "MS-DOS Text"
' Combo1.ItemData(Combo1.NewIndex) = xlTextMSDOS
' Combo1.AddItem "Lotus 123 (WK1)"
' Combo1.ItemData(Combo1.NewIndex) = xlWK1
' Combo1.AddItem "Lotus 123 (WKS)"
' Combo1.ItemData(Combo1.NewIndex) = xlWKS
' Combo1.AddItem "Quattro Pro"
' Combo1.ItemData(Combo1.NewIndex) = xlWQ1
'
' Combo1.ListIndex = 0
 
End Sub

Answer 2

Option Explicit
Private xlApp As Object
Private xlBook As Object
Private xlSheet As ObjectPublic Function GetData(ByVal row As Integer, ByVal Col As Integer) As String
GetData = xlSheet.Cells(row, Col)
End FunctionPublic Sub CloseExcel()
xlApp.Quit
Set xlApp = Nothing
Set xlBook = Nothing
Set xlSheet = Nothing
End SubPublic Sub OpenExcel(ByVal FileName As String)
xlApp.Workbooks.Open FileName:=FileName
Set xlBook = xlApp.Workbooks(1)
Set xlSheet = xlBook.Worksheets(1)
End SubPublic Sub CreateExcel()
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = False
End SubPublic Sub PutData(ByVal row As Integer, ByVal Col As Integer, ByVal Value As String)
xlSheet.Cells(row, Col) = Value
End SubPublic Sub SaveExcel()
xlBook.Save
End SubPublic Sub SaveExcelAs(ByVal FileName As String)
Set xlApp = CreateObject("Excel.Application")
Set xlBook = xlApp.Workbooks.Add
xlBook.SaveAs FileName
Set xlSheet = xlBook.Worksheets(1)
End Sub