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 IfFileCopy 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 jExcel_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 = 0Exit Sub100: MsgBox "导出出错。" Excel_WorkBook.Save Excel_WorkBook.Close Excel_File.Quit Unload Frm_JinDu
S_Out = "select 发货序号,convert(char(10),发货日期,111) as 发货日期,收货单位,订单号码,品名,规格,重量,单位,单价,总价 as 含税总价,含税,包装,箱数,结帐 as 对账,开票,作废,备注 from md_send_dj " Call ExporToExcel(S_Out, Connection) 'S_Out为查询语句;Connection为联接字符串 Public Function ExporToExcel(strOpen As String,connection As String) '********************************************************* '* 名称:ExporToExcel '* 功能:导出数据到EXCEL '* 用法:ExporToExcel(sql查询字符串) '********************************************************* 'Dim cn As New ADODB.Connection Dim Rs_Data As New ADODB.Recordset Dim Irowcount As Integer Dim Icolcount As Integer Dim xlApp As New Excel.Application Dim xlBook As Excel.Workbook Dim xlSheet As Excel.Worksheet Dim xlQuery As Excel.QueryTable ' cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source ='" + App.Path & "\info.mdb" + "' ;Persist Security Info=False" With Rs_Data If .State = adStateOpen Then .Close End If .ActiveConnection = Connection .CursorLocation = adUseClient .CursorType = adOpenStatic .LockType = adLockReadOnly .Source = strOpen .Open End With ' Rs_Data.Open strOpen, Cn, adOpenStatic, adLockReadOnly With Rs_Data ' .MoveFirst If .RecordCount < 1 Then MsgBox ("没有记录!") Exit Function End If '记录总数 Irowcount = .RecordCount '字段总数 Icolcount = .Fields.Count End With Set xlApp = CreateObject("Excel.Application") Set xlBook = Nothing Set xlSheet = Nothing Set xlBook = xlApp.Workbooks().Add Set xlSheet = xlBook.Worksheets("sheet1") xlApp.Visible = True '添加查询语句,导入EXCEL数据 Set xlQuery = xlSheet.QueryTables.Add(Rs_Data, xlSheet.Range("a1")) With xlQuery .FieldNames = True .RowNumbers = False .FillAdjacentFormulas = False .PreserveFormatting = True .RefreshOnFileOpen = False .BackgroundQuery = True .RefreshStyle = xlInsertDeleteCells .SavePassword = True .SaveData = True .AdjustColumnWidth = True .RefreshPeriod = 0 .PreserveColumnInfo = True End With xlQuery.FieldNames = True '显示字段名 xlQuery.Refresh With xlSheet .Range(.Cells(1, 1), .Cells(1, Icolcount)).Font.Name = "黑体" '设标题为黑体字 .Range(.Cells(1, 1), .Cells(1, Icolcount)).Font.Bold = True '标题字体加粗 .Range(.Cells(1, 1), .Cells(Irowcount + 1, Icolcount)).Borders.LineStyle = xlContinuous '设表格边框样式 End With 'With xlSheet.PageSetup ' .LeftHeader = "" & Chr(10) & "&""楷体_GB2312,常规""&10公司名称:无锡巨丰漆包线厂" ' & Gsmc ' .CenterHeader = "&""楷体_GB2312,常规""发货情况表&""宋体,常规""" & Chr(10) & "&""楷体_GB2312,常规""&10日 期:" ' .RightHeader = "" & Chr(10) & "&""楷体_GB2312,常规""&10单位:" ' .LeftFooter = "&""楷体_GB2312,常规""&10制表人:" ' .CenterFooter = "&""楷体_GB2312,常规""&10制表日期:" ' .RightFooter = "&""楷体_GB2312,常规""&10第&P页 共&N页" 'End With xlApp.Application.Visible = True Set xlApp = Nothing '"交还控制给Excel Set xlBook = Nothing Set xlSheet = Nothing
'Dim P As Integer, P1 As Integer 'Dim Str_Temp As String
'Str_Temp = FileName 'P = 0 'P1 = 0 'For i = 1 To Len(FileName) ' P1 = InStr(1, Mid(Str_Temp, 1, (Len(FileName) - P)), "\") ' If P1 > 0 Then ' P = P1 + P ' Str_Temp = Right(Str_Temp, (Len(Str_Temp) - P1)) ' Else ' Exit For ' End If 'Next
For lngRow = 1 To .ListItems.Count For lngCol = 1 To .ColumnHeaders.Count - 1
If lngFlag = 0 Or InStr(strFields, .ColumnHeaders(lngCol + 1).TEXT) <> 0 Then xlsWorksheet.Cells(lngRow + 1, lngCol).NumberFormatLocal = "@" Else xlsWorksheet.Cells(lngRow, lngCol).NumberFormatLocal = "0.00" End If If .ColumnHeaders(lngCol + 1).Width <> 0 Then If lngRow = 1 Then xlsWorksheet.Cells(lngRow, lngCol) = .ColumnHeaders.Item(lngCol + 1).TEXT End If xlsWorksheet.Cells(lngRow + 1, lngCol) = Trim(.ListItems(lngRow).SubItems(lngCol)) End If
Next End With 可以将上面的代码当做一个过程 然后用的时候, Call subExpertToExcel(Me, lvwlist) Call 过程名字(窗体名称、控件名称)
Option ExplicitPrivate Sub Command1_Click() Dim Conn As New ADODB.Connection Dim Rs As New ADODB.Recordset Dim ExcelApp As New Excel.Application Dim WorkBookObj As Workbook Dim SheetObj As Worksheet
Conn.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.Path & "\aa.mdb" Conn.Open Rs.Open "Select * From aa", Conn, adOpenKeyset, adLockOptimistic, adCmdText '========================================================================== Set WorkBookObj = ExcelApp.Workbooks.Open(App.Path & "\bbb.xls") Set SheetObj = WorkBookObj.Worksheets(1) '======================================== SheetObj.Range("A1").CopyFromRecordset Rs '======================================== Set SheetObj = Nothing WorkBookObj.Save WorkBookObj.Close Set WorkBookObj = Nothing ExcelApp.Quit Set ExcelApp = Nothing Rs.Close Set Rs = Nothing Conn.Close Set Conn = Nothing MsgBox "OK!请您打开bbb.xls文件察看!" End Sub
'输出到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 IfFileCopy 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 jExcel_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 = 0Exit Sub100:
MsgBox "导出出错。"
Excel_WorkBook.Save
Excel_WorkBook.Close
Excel_File.Quit
Unload Frm_JinDu
Call ExporToExcel(S_Out, Connection) 'S_Out为查询语句;Connection为联接字符串
Public Function ExporToExcel(strOpen As String,connection As String)
'*********************************************************
'* 名称:ExporToExcel
'* 功能:导出数据到EXCEL
'* 用法:ExporToExcel(sql查询字符串)
'*********************************************************
'Dim cn As New ADODB.Connection
Dim Rs_Data As New ADODB.Recordset
Dim Irowcount As Integer
Dim Icolcount As Integer Dim xlApp As New Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim xlQuery As Excel.QueryTable
' cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source ='" + App.Path & "\info.mdb" + "' ;Persist Security Info=False"
With Rs_Data
If .State = adStateOpen Then
.Close
End If
.ActiveConnection = Connection
.CursorLocation = adUseClient
.CursorType = adOpenStatic
.LockType = adLockReadOnly
.Source = strOpen
.Open
End With
' Rs_Data.Open strOpen, Cn, adOpenStatic, adLockReadOnly
With Rs_Data
' .MoveFirst
If .RecordCount < 1 Then
MsgBox ("没有记录!")
Exit Function
End If
'记录总数
Irowcount = .RecordCount
'字段总数
Icolcount = .Fields.Count
End With
Set xlApp = CreateObject("Excel.Application")
Set xlBook = Nothing
Set xlSheet = Nothing
Set xlBook = xlApp.Workbooks().Add
Set xlSheet = xlBook.Worksheets("sheet1")
xlApp.Visible = True
'添加查询语句,导入EXCEL数据
Set xlQuery = xlSheet.QueryTables.Add(Rs_Data, xlSheet.Range("a1")) With xlQuery
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = True
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.PreserveColumnInfo = True
End With xlQuery.FieldNames = True '显示字段名
xlQuery.Refresh With xlSheet
.Range(.Cells(1, 1), .Cells(1, Icolcount)).Font.Name = "黑体"
'设标题为黑体字
.Range(.Cells(1, 1), .Cells(1, Icolcount)).Font.Bold = True
'标题字体加粗
.Range(.Cells(1, 1), .Cells(Irowcount + 1, Icolcount)).Borders.LineStyle = xlContinuous
'设表格边框样式
End With 'With xlSheet.PageSetup
' .LeftHeader = "" & Chr(10) & "&""楷体_GB2312,常规""&10公司名称:无锡巨丰漆包线厂" ' & Gsmc
' .CenterHeader = "&""楷体_GB2312,常规""发货情况表&""宋体,常规""" & Chr(10) & "&""楷体_GB2312,常规""&10日 期:"
' .RightHeader = "" & Chr(10) & "&""楷体_GB2312,常规""&10单位:"
' .LeftFooter = "&""楷体_GB2312,常规""&10制表人:"
' .CenterFooter = "&""楷体_GB2312,常规""&10制表日期:"
' .RightFooter = "&""楷体_GB2312,常规""&10第&P页 共&N页"
'End With
xlApp.Application.Visible = True
Set xlApp = Nothing '"交还控制给Excel
Set xlBook = Nothing
Set xlSheet = Nothing
'Dim P As Integer, P1 As Integer
'Dim Str_Temp As String
'Str_Temp = FileName
'P = 0
'P1 = 0
'For i = 1 To Len(FileName)
' P1 = InStr(1, Mid(Str_Temp, 1, (Len(FileName) - P)), "\")
' If P1 > 0 Then
' P = P1 + P
' Str_Temp = Right(Str_Temp, (Len(Str_Temp) - P1))
' Else
' Exit For
' End If
'Next
'If P > 0 Then ChDir Left(FileName, (P - 1))
'ActiveWorkbook.SaveAs FileName:=FileName, FileFormat:=xlNormal _
' , Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
' CreateBackup:=False
End Function
Set xlsWorkbook = xlsapp.Workbooks.Add
Set xlsWorksheet = xlsWorkbook.Worksheets(1)
frmForm.lblCaption.Caption = "填充数据......"
' xlsapp.Visible = True
With lvwListView
xlsWorksheet.Range(xlsWorksheet.Cells(1, 1), xlsWorksheet.Cells(1, .ColumnHeaders.Count)).Font.FontStyle = "加粗"
xlsWorksheet.Cells.Font.Name = "Arial"
xlsWorksheet.Cells.Font.Size = 10
For lngRow = 1 To .ListItems.Count
For lngCol = 1 To .ColumnHeaders.Count - 1
If lngFlag = 0 Or InStr(strFields, .ColumnHeaders(lngCol + 1).TEXT) <> 0 Then
xlsWorksheet.Cells(lngRow + 1, lngCol).NumberFormatLocal = "@"
Else
xlsWorksheet.Cells(lngRow, lngCol).NumberFormatLocal = "0.00"
End If If .ColumnHeaders(lngCol + 1).Width <> 0 Then
If lngRow = 1 Then
xlsWorksheet.Cells(lngRow, lngCol) = .ColumnHeaders.Item(lngCol + 1).TEXT
End If
xlsWorksheet.Cells(lngRow + 1, lngCol) = Trim(.ListItems(lngRow).SubItems(lngCol))
End If
frmForm.prgProgress.Value = frmForm.prgProgress.Value + 1
Next
Next End With
可以将上面的代码当做一个过程
然后用的时候,
Call subExpertToExcel(Me, lvwlist)
Call 过程名字(窗体名称、控件名称)
Dim Conn As New ADODB.Connection
Dim Rs As New ADODB.Recordset
Dim ExcelApp As New Excel.Application
Dim WorkBookObj As Workbook
Dim SheetObj As Worksheet
Conn.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.Path & "\aa.mdb"
Conn.Open
Rs.Open "Select * From aa", Conn, adOpenKeyset, adLockOptimistic, adCmdText
'==========================================================================
Set WorkBookObj = ExcelApp.Workbooks.Open(App.Path & "\bbb.xls")
Set SheetObj = WorkBookObj.Worksheets(1)
'========================================
SheetObj.Range("A1").CopyFromRecordset Rs
'========================================
Set SheetObj = Nothing
WorkBookObj.Save
WorkBookObj.Close
Set WorkBookObj = Nothing
ExcelApp.Quit
Set ExcelApp = Nothing
Rs.Close
Set Rs = Nothing
Conn.Close
Set Conn = Nothing
MsgBox "OK!请您打开bbb.xls文件察看!"
End Sub