在vb中利用按钮把access查询内容导入到excel 002
2006-03-10 15:16
274 查看
Public Sub ExportToExcel(ado As Adodc, DG As DataGrid, startCol As Integer, EndCol As Integer, StrTitle As String)
'输出到EXCEL表中
'数据来源于ado和dg,strtitle为第一行第一列显示的内容,即表名
'startCol为要导出的dataGrid的起始列,可能会需要不导出数据的前几列
'endCol为要导出的dataGrid的终止列
Dim Excel_File As New Excel.Application
Dim Excel_WorkBook As Excel.Workbook
Dim Excel_Sheet As Excel.Worksheet
Dim savename, s As String
Dim j, k As Integer
Dim jindu, k1 As Single
'创建excel文件
Frm_Main.CommonDialog1.filename = StrTitle
Frm_Main.CommonDialog1.Filter = "*.xls|*.xls"
Frm_Main.CommonDialog1.CancelError = True
On Error GoTo L1
Frm_Main.CommonDialog1.DialogTitle = "输入要创建的Excel文件名"
Frm_Main.CommonDialog1.FilterIndex = 2
Frm_Main.CommonDialog1.ShowSave
L1:
If err.Number = cdlCancel Then
err.Clear
Exit Sub
End If
If Frm_Main.CommonDialog1.filename = "" Then Exit Sub
savename = Frm_Main.CommonDialog1.filename
''拆分savenae并判 断有无此文件
If IsSaveFileNameExist(savename) = True Then
MsgBox "已有此文件,另输入一个文件名。"
Exit Sub
End If
FileCopy App.path & "/table.xls", savename
'打开创建的文件并输出
On Error GoTo 100
If ado.Recordset.RecordCount = 0 Then
MsgBox "无记录。", vbInformation + vbOKOnly, DlgTitle
Exit Sub
End If
Frm_JinDu.Show
Frm_JinDu.Command2.Enabled = False
Frm_JinDu.MousePointer = 11
'进度还原
Frm_JinDu.Label3.Width = 0
If ado.Recordset.RecordCount <= 0 Then
Exit Sub
End If
jindu = 100 / ado.Recordset.RecordCount
Frm_JinDu.Label1.Caption = "准备导出..."
Set Excel_File = CreateObject("Excel.application")
If Excel_File Is Nothing Then
MsgBox "请检查是否安装microsoft EXCEL软件", , DlgTitle
Exit Sub
End If
On Error GoTo 100
Set Excel_WorkBook = Excel_File.Workbooks.Open(savename)
If Excel_WorkBook Is Nothing Then
MsgBox "请检查是否存在" & savename & "文件。", , DlgTitle
Exit Sub
End If
Set Excel_Sheet = Excel_WorkBook.Worksheets("Sheet1")
If Excel_Sheet Is Nothing Then
MsgBox "请检查 " & savename & " 文件中SHEET1是否存在。", , DlgTitle
Exit Sub
End If
Excel_File.Sheets("Sheet1").Select
Excel_File.Range("A1:U100").Select
Excel_File.Selection.ClearContents
Excel_File.Range("A4").Select
s = "B2"
Excel_Sheet.Range(s).Font.Size = 12
Frm_JinDu.Label1.Caption = "正在导出..."
'表头
Excel_Sheet.Cells(1, 1) = StrTitle
For j = 0 To 0
DG.Row = j
For k = startCol To DG.Columns.Count - EndCol
DG.Col = k
Excel_Sheet.Cells(j + 2, k + 1 - startCol) = DG.Columns(k).Caption
Next k
Next j
'表资料
ado.Recordset.MoveFirst
For j = 0 To ado.Recordset.RecordCount - 1
'DG.Row = j
For k = startCol To DG.Columns.Count - EndCol
'DG.Col = k
Excel_Sheet.Cells(j + 3, k + 1 - startCol) = ado.Recordset.Fields(k).Value 'DG.Text
Next k
'显示进度
Frm_JinDu.Label3.Width = Frm_JinDu.Label3.Width + Frm_JinDu.Picture1.Width / ado.Recordset.RecordCount
k1 = k1 + jindu
DoEvents
Frm_JinDu.Label4.Caption = CInt(k1) & "%"
ado.Recordset.MoveNext
Next j
Excel_WorkBook.Save
Excel_WorkBook.Close
Excel_File.Quit
Frm_JinDu.Label1.Caption = "导出完成,数据被导入" & savename & "中。"
Frm_JinDu.Command2.Enabled = True
Frm_JinDu.Command2.SetFocus
Frm_JinDu.MousePointer = 0
Exit Sub
100:
MsgBox "导出出错。"
Excel_WorkBook.Save
Excel_WorkBook.Close
Excel_File.Quit
Unload Frm_JinDu
'输出到EXCEL表中
'数据来源于ado和dg,strtitle为第一行第一列显示的内容,即表名
'startCol为要导出的dataGrid的起始列,可能会需要不导出数据的前几列
'endCol为要导出的dataGrid的终止列
Dim Excel_File As New Excel.Application
Dim Excel_WorkBook As Excel.Workbook
Dim Excel_Sheet As Excel.Worksheet
Dim savename, s As String
Dim j, k As Integer
Dim jindu, k1 As Single
'创建excel文件
Frm_Main.CommonDialog1.filename = StrTitle
Frm_Main.CommonDialog1.Filter = "*.xls|*.xls"
Frm_Main.CommonDialog1.CancelError = True
On Error GoTo L1
Frm_Main.CommonDialog1.DialogTitle = "输入要创建的Excel文件名"
Frm_Main.CommonDialog1.FilterIndex = 2
Frm_Main.CommonDialog1.ShowSave
L1:
If err.Number = cdlCancel Then
err.Clear
Exit Sub
End If
If Frm_Main.CommonDialog1.filename = "" Then Exit Sub
savename = Frm_Main.CommonDialog1.filename
''拆分savenae并判 断有无此文件
If IsSaveFileNameExist(savename) = True Then
MsgBox "已有此文件,另输入一个文件名。"
Exit Sub
End If
FileCopy App.path & "/table.xls", savename
'打开创建的文件并输出
On Error GoTo 100
If ado.Recordset.RecordCount = 0 Then
MsgBox "无记录。", vbInformation + vbOKOnly, DlgTitle
Exit Sub
End If
Frm_JinDu.Show
Frm_JinDu.Command2.Enabled = False
Frm_JinDu.MousePointer = 11
'进度还原
Frm_JinDu.Label3.Width = 0
If ado.Recordset.RecordCount <= 0 Then
Exit Sub
End If
jindu = 100 / ado.Recordset.RecordCount
Frm_JinDu.Label1.Caption = "准备导出..."
Set Excel_File = CreateObject("Excel.application")
If Excel_File Is Nothing Then
MsgBox "请检查是否安装microsoft EXCEL软件", , DlgTitle
Exit Sub
End If
On Error GoTo 100
Set Excel_WorkBook = Excel_File.Workbooks.Open(savename)
If Excel_WorkBook Is Nothing Then
MsgBox "请检查是否存在" & savename & "文件。", , DlgTitle
Exit Sub
End If
Set Excel_Sheet = Excel_WorkBook.Worksheets("Sheet1")
If Excel_Sheet Is Nothing Then
MsgBox "请检查 " & savename & " 文件中SHEET1是否存在。", , DlgTitle
Exit Sub
End If
Excel_File.Sheets("Sheet1").Select
Excel_File.Range("A1:U100").Select
Excel_File.Selection.ClearContents
Excel_File.Range("A4").Select
s = "B2"
Excel_Sheet.Range(s).Font.Size = 12
Frm_JinDu.Label1.Caption = "正在导出..."
'表头
Excel_Sheet.Cells(1, 1) = StrTitle
For j = 0 To 0
DG.Row = j
For k = startCol To DG.Columns.Count - EndCol
DG.Col = k
Excel_Sheet.Cells(j + 2, k + 1 - startCol) = DG.Columns(k).Caption
Next k
Next j
'表资料
ado.Recordset.MoveFirst
For j = 0 To ado.Recordset.RecordCount - 1
'DG.Row = j
For k = startCol To DG.Columns.Count - EndCol
'DG.Col = k
Excel_Sheet.Cells(j + 3, k + 1 - startCol) = ado.Recordset.Fields(k).Value 'DG.Text
Next k
'显示进度
Frm_JinDu.Label3.Width = Frm_JinDu.Label3.Width + Frm_JinDu.Picture1.Width / ado.Recordset.RecordCount
k1 = k1 + jindu
DoEvents
Frm_JinDu.Label4.Caption = CInt(k1) & "%"
ado.Recordset.MoveNext
Next j
Excel_WorkBook.Save
Excel_WorkBook.Close
Excel_File.Quit
Frm_JinDu.Label1.Caption = "导出完成,数据被导入" & savename & "中。"
Frm_JinDu.Command2.Enabled = True
Frm_JinDu.Command2.SetFocus
Frm_JinDu.MousePointer = 0
Exit Sub
100:
MsgBox "导出出错。"
Excel_WorkBook.Save
Excel_WorkBook.Close
Excel_File.Quit
Unload Frm_JinDu
相关文章推荐
- vb中怎样将excel表导入到access中
- [转载]利用SQL Server的DTS操作EXCEL、Access等数据表的导入导出
- 利用JS把Table中的内容导入到Excel中的方法
- VB把excel数据导入ACCESS
- 利用SQL Server的DTS操作EXCEL、Access等数据表的导入导出- -
- Access中一句查询代码实现Excel数据导入导出
- 如何利用phpMyAdmin批量导入Excel内容到MySQL
- vb连接access excel步骤 excel 导入access
- 利用SQL Server的DTS操作EXCEL、Access等数据表的导入导出
- VB的MSHFlexGrid控件内容导入Excel
- VB的MSHFlexGrid控件内容导入Excel
- Java 利用POI实现将数据库中内容导入到EXcel中
- vb(5) 将查询导入Excel
- Java 利用POI实现将数据库中内容导入到EXcel中
- 利用vba 从excel到access中导入与导出表
- [办公自动化] 再读《让EXCEL飞》(从excel导入access数据时,union联合查询,数据源中没有包含可见的表格)
- 利用JS把Table中的内容导入到Excel中的方法
- 利用SQL Server的DTS操作EXCEL、Access等数据表的导入导出
- C#开发的高性能EXCEL导入、导出工具DataPie(支持MSSQL、ORACLE、ACCESS,附源码下载地址)
- C#开发的高性能EXCEL导入、导出工具DataPie(支持MSSQL、ORACLE、ACCESS,附源码下载地址)