送分100分：如何将DATAGRID或DATA REPORT报表中的数据导出到EXCEL中

Question

在VB6中，如何将DATAGRID或DATA REPORT报表中的数据导出到EXCEL中。开发环境是VB6+ACCESS+ADO+DATAGRID+DATA REPORT.

Answer 1

来段操作Excel的代码：
标准模块代码：
'％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％
'模块功能：
'设计单位：
'设 计 者：
'设计时间：
'％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％
Option Explicit
Public xlsApp As Excel.Application      'Excel应用对象
Public xlsBook As Excel.Workbook        'Excel工作薄对象
Public xlsSheet As Excel.Worksheet      'Excel工作表对象
'％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％
'函数功能：打开指定的Excel文件
'参数说明：xlsAPP：Excel应用对象
'        ：xlsWork：Excel工作薄对象
'        ：xlsSheet：Excel工作表对象
'        ：strExcelFile：Excel文件路径
'        ：strSheetName：工作表名
'        ：strPWD：密码
'        ：bolVisible：表的可见性
'％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％
Public Function funOpenExcelFile(ByRef xlsApp As Excel.Application, _
                                 ByRef xlsWork As Excel.Workbook, _
                                 ByRef xlsSheet As Excel.Worksheet, _
                                 ByVal strExcelFile As String, _
                                 ByVal strSheetName As String, _
                                 ByVal strPWD As String, _
                                 ByVal bolVisible As Boolean) As Boolean
On Error GoTo errFun
    funOpenExcelFile = False
    Set xlsApp = CreateObject("Excel.Application")
    Set xlsWork = xlsApp.Workbooks.Open(strExcelFile, , False, , strPWD, strPWD)
    Set xlsSheet = xlsBook.Worksheets(strSheetName)
    xlsSheet.Activate
    xlsApp.Visible = bolVisible
    funOpenExcelFile = True
    Exit Function
errFun:
    funOpenExcelFile = False
End Function
'％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％
'函数功能：关闭指定的Excel文件
'参数说明：xlsAPP：Excel应用对象
'        ：xlsWork：Excel工作薄对象
'        ：xlsSheet：Excel工作表对象
'        ：bolSave：是否保存
'％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％
Public Function funCloseExcelFile(ByRef xlsApp As Excel.Application, _
                                 ByRef xlsWork As Excel.Workbook, _
                                 ByRef xlsSheet As Excel.Worksheet, _
                                 ByVal bolSave As Boolean) As Boolean
On Error GoTo errFun
    If bolSave Then xlsBook.Save
    Set xlsSheet = Nothing
    xlsBook.Close
    Set xlsBook = Nothing
    Set xlsApp = Nothing
    funCloseExcelFile = True
    Exit Function
errFun:
    funCloseExcelFile = False
End Function
'％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％
'函数功能：读取指定单元格的内容
'参数说明：xlsSheet：工作表对象
'        ：lngRow：行号
'        ：lngCol：列号
'％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％
Public Function funReadCellText(ByRef xlsSheet As Excel.Worksheet, _
                                ByVal lngRow As Long, _
                                ByVal lngCol As Long) As String
    
On Error GoTo errFun
    funReadCellText = ""
    If lngRow <= 0 Or lngCol <= 0 Then Exit Function
    funReadCellText = xlsSheet.Cells(lngRow, lngCol)
    Exit Function
errFun:
    funReadCellText = ""
End Function
'％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％
'函数功能：设置指定单元格的内容
'参数说明：xlsSheet：工作表对象
'        ：lngRow：行号
'        ：lngCol：列号
'％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％
Public Function funSetCellText(ByRef xlsSheet As Excel.Worksheet, _
                                ByVal lngRow As Long, _
                                ByVal lngCol As Long, _
                                ByVal strSetCellText As String) As Boolean
    
On Error GoTo errFun
    funSetCellText = False
    If lngRow <= 0 Or lngCol <= 0 Then Exit Function
    xlsSheet.Cells(lngRow, lngCol) = strSetCellText
    funSetCellText = True
    Exit Function
errFun:
    funSetCellText = ""
End Function
窗体模块：'％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％
'模块功能：
'设计单位：
'设 计 者：
'设计时间：
'％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％
Option ExplicitPrivate Sub Command1_Click()
    Dim bolP As Boolean
    bolP = funOpenExcelFile(xlsApp, xlsBook, xlsSheet, App.Path & "\111.xls", "Sheet1", "", True)
End SubPrivate Sub Command2_Click()
    Dim bolP As Boolean
    bolP = funSetCellText(xlsSheet, 2, 2, "123456")
End SubPrivate Sub Command3_Click()
    Label1.Caption = funReadCellText(xlsSheet, 2, 2)
End SubPrivate Sub Command4_Click()
    Dim bolP As Boolean
    bolP = funCloseExcelFile(xlsApp, xlsBook, xlsSheet, True)
End Sub

Answer 2

'office 2003 工程中引用 Microsoft office 11.0 Object;
Private Sub Command4_Click()
  Dim i As Long, j As Long
  Dim xlsApp As Excel.Application
  Dim xlsBook As Excel.Workbook
  Dim xlssheet As Excel.Worksheet
  Set xlsApp = New Excel.Application
  Set xlsApp = CreateObject("Excel.Application")
  xlsApp.Visible = True
  Set xlsBook = xlsApp.Workbooks.Open(App.Path & "\filename.xls")
  Set xlssheet = xlsBook.Worksheets(1)
  rs.MoveFirst
  For i = 1 To rs.Fields.Count
     xlssheet.Cells(1, i) = rs.Fields(i - 1).Name
  Next
  For i = 1 To rs.RecordCount
     For j = 1 To DataGrid1.Columns.Count
       With xlssheet
          .Cells(i + 1, j) = DataGrid1.Columns(j - 1).Value
       End With
     Next j
     rs.MoveNext
  Next i
End Sub

Answer 3

以下Code修改一下，
應該ok;
Private Sub OutputToExcel_Click()
'2009.10.20 修改'Dim sNWind As StringDim conn As New ADODB.Connection
Dim rs As ADODB.Recordset
Dim xlsheet As Excel.Worksheet'修改：把"絕對路徑"改成"相對路徑"'sNWind = "C:\Documents and Settings\goldenzhong\桌面\分析維修管理系統\information.mdb"'conn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & sNWind & ";"conn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.Path & "\information.mdb;"
conn.CursorLocation = adUseClient
Set rs = conn.Execute("Info", , adCmdTable)
'在Excel中创建新的workbookDim oExcel As Object
Dim oBook As Object
Dim oSheet As Excel.Worksheet
Set oExcel = CreateObject("Excel.Application")
Set oBook = oExcel.Workbooks.Add
Set oSheet = oBook.Worksheets(1)'向 Excel中传输数据oSheet.Range("A1").CopyFromRecordset rs
'保存并退出Excel'修改原因：讓用戶選擇"保存路徑"及“文件名”？'2009.10.23 修改 打開變成另存為
'CommonDialog1.ShowOpen
CommonDialog1.ShowSave
'2009.10.22 修改  修改目的:導出execl表有標題
If rs.RecordCount > 0 Then    For i = 1 To rs.Fields.Count
        'oSheet.Cells(1, i) = rs.Fields(i - 1).Name
        oSheet.Cells(1, i) = DataGrid1.Columns(i - 1).Caption               '調用Datgrid1.Columns(i-1)字段名
    Next i
    
    'For i = 1 To rs.Fields.Count
        'oSheet.Cells(1, i).HorizontalAlignment = xlCenter
        'Range("A?").HorizontalAlignment = xlCenter
    'Next i
    
    oSheet.Columns("A:AC").HorizontalAlignment = xlCenter                   '所有行居中
    'CommonDialog1.Filter = "execl(*.xls)*.xls"
    'CommonDialog1.Filter = "*.xls"               ' 異常,直接CommonDialog1屬性Filter設置
    '如果保存文件名與保存文件夾中文件的文件名相同,將報錯(選擇"取消","否")
    If Len(CommonDialog1.FileName) > 3 Then
        oBook.SaveAs CommonDialog1.FileName
        MsgBox "導出Execl成功!", 0, "提示"
        oExcel.Quit
    End If
End If'oBook.SaveAs "C:\Documents and Settings\goldenzhong\桌面\Book1.xls"
'关闭连接rs.Close
conn.CloseEnd Sub

Answer 4

On Error GoTo Hand        Dim xlApp As New Excel.Application
        Dim xlWorkbook As Excel.Workbook
        Dim xlSheet As Excel.Worksheet
        Dim xlQuery As Excel.QueryTable
        xlApp.Visible = True
        Set xlWorkbook = xlApp.Workbooks.Add
        Set xlSheet = xlWorkbook.Worksheets(1)
        Set xlQuery = xlSheet.QueryTables.Add(Adodc1.Recordset, xlSheet.Range("A1"))
        xlQuery.FieldNames = True
        xlQuery.Refresh
        Exit Sub
Hand:
        MsgBox Err.Description, vbCritical, "导入失败"
这样就可以了，放到一个按钮下就行了

Answer 5

要引用microsoft excel 12.0 object library

Answer 6

解决数据库【Table-->Excel】的导出即可、其余形式仅为：变种。这个VB的程序段：微软网站就有。查一下即可。