送分100分：如何将DATAGRID或DATA REPORT报表中的数据导出到EXCEL中
在VB6中，如何将DATAGRID或DATA REPORT报表中的数据导出到EXCEL中。开发环境是VB6+ACCESS+ADO+DATAGRID+DATA REPORT. --------------------编程问答-------------------- 来段操作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
窗体模块：
--------------------编程问答-------------------- 'office 2003 工程中引用 Microsoft office 11.0 Object;
'％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％
'模块功能：
'设计单位：
'设 计 者：
'设计时间：
'％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％％
Option Explicit
Private Sub Command1_Click()
Dim bolP As Boolean
bolP = funOpenExcelFile(xlsApp, xlsBook, xlsSheet, App.Path & "\111.xls", "Sheet1", "", True)
End Sub
Private Sub Command2_Click()
Dim bolP As Boolean
bolP = funSetCellText(xlsSheet, 2, 2, "123456")
End Sub
Private Sub Command3_Click()
Label1.Caption = funReadCellText(xlsSheet, 2, 2)
End Sub
Private Sub Command4_Click()
Dim bolP As Boolean
bolP = funCloseExcelFile(xlsApp, xlsBook, xlsSheet, True)
End Sub
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
--------------------编程问答-------------------- 以下Code修改一下，
應該ok;
--------------------编程问答-------------------- On Error GoTo Hand
Private Sub OutputToExcel_Click()
'2009.10.20 修改
'Dim sNWind As String
Dim 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中创建新的workbook
Dim 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.Close
End Sub
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, "导入失败"
这样就可以了，放到一个按钮下就行了 --------------------编程问答-------------------- 要引用microsoft excel 12.0 object library --------------------编程问答--------------------
可以不引用； --------------------编程问答-------------------- 解决数据库【Table-->Excel】的导出即可、其余形式仅为：变种。这个VB的程序段：微软网站就有。查一下即可。 --------------------编程问答--------------------
补充：VB , 数据库(包含打印，安装，报表)
