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

通过一个程序来实现如下功能：  
生成一个excel文件；将所获得的数据写入该文件。  

5 个解决方案

#1

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

#2

你好，辛苦了

#3

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 = Nothing

Screen.MousePointer = vbDefault
End Sub
''*******************SAMPLE USAGE BELOW***********************
'Private Sub Command1_Click()
' SaveAsExcel Data1.Recordset.Clone(), Text1.Text, _
'    Combo1.ItemData(Combo1.ListIndex)
'End Sub



Private 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

#4

Option Explicit
Private xlApp As Object
Private xlBook As Object
Private xlSheet As Object

Public Function GetData(ByVal row As Integer, ByVal Col As Integer) As String
GetData = xlSheet.Cells(row, Col)
End Function

Public Sub CloseExcel()
xlApp.Quit
Set xlApp = Nothing
Set xlBook = Nothing
Set xlSheet = Nothing
End Sub

Public Sub OpenExcel(ByVal FileName As String)
xlApp.Workbooks.Open FileName:=FileName
Set xlBook = xlApp.Workbooks(1)
Set xlSheet = xlBook.Worksheets(1)
End Sub

Public Sub CreateExcel()
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = False
End Sub

Public Sub PutData(ByVal row As Integer, ByVal Col As Integer, ByVal Value As String)
xlSheet.Cells(row, Col) = Value
End Sub

Public Sub SaveExcel()
xlBook.Save
End Sub

Public 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

#5

谢谢各位前辈！