Public Function ExporToExcel() '********************************************************* '* 名称:ExporToExcel '* 功能:导出数据到EXCEL '* 用法:ExporToExcel(sql查询字符串) '********************************************************* 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 Set Rs_Data = Adodc1.Recordset
'With Rs_Data 'If .State = adStateOpen Then ' .Close ' End If '.ActiveConnection = Cn ' .CursorLocation = adUseClient '.CursorType = adOpenStatic '.LockType = adLockReadOnly '.Source = strOpen '.Open 'End With With Rs_Data If .RecordCount < 1 Then MsgBox "对不起!你的选择是错误的数据库没有记录!我想你应该不会在选择错了!", vbOKOnly + vbInformation, "提示" 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"))
xlApp.Application.Visible = True On Error Resume Next xlBook.SaveAs
If xlBook.Saved = True Then MsgBox "导出成功!!文件在我的文档资料夹请另存!", vbOKOnly + vbInformation, "提示" ElseIf xlBook.Saved = False Then MsgBox "文件没有保存请重新导出!", vbOKOnly + vbInformation, "提示" End If Set xlApp = Nothing '"交还控制给Excel Set xlBook = Nothing Set xlSheet = Nothing xlApp.Quit End Function
adoConnection.Open "Provider=Microsoft.Jet.OLEDB.4.0;Persist Security Info=False;Data Source=" & strFileName & ";Extended Properties='Excel 8.0;HDR=Yes'" adoRecordset.Open "select * from [students.sheet$]", adoConnection, adOpenKeyset, adLockOptimistic Do While Not adoRecordset.EOF '执行你的动作 adoRecordset.MoveNext Loop adoRecordset.Close adoConnection.Close
Public Function Read_Excel _ (ByVal sFile _ As String) As ADODB.Recordset On Error GoTo fix_err Dim rs As ADODB.Recordset Set rs = New ADODB.Recordset Dim sconn As String rs.CursorLocation = adUseClient rs.CursorType = adOpenKeyset rs.LockType = adLockBatchOptimistic sconn = "DRIVER=Microsoft Excel Driver (*.xls);" & "DBQ=" & sFile rs.Open "SELECT * FROM [sheet1$]", sconn Set Read_Excel = rs Set rs = Nothing Exit Function fix_err: Debug.Print Err.Description + " " + _ Err.Source, vbCritical, "Import" Err.Clear End FunctionPrivate Sub cmdReadXLS_Click() Set dgData.DataSource = Read_Excel(App.Path & "\" & "test.xls") Set obj = Nothing End Sub
'*********************************************************
'* 名称:ExporToExcel
'* 功能:导出数据到EXCEL
'* 用法:ExporToExcel(sql查询字符串)
'*********************************************************
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
Set Rs_Data = Adodc1.Recordset
'With Rs_Data
'If .State = adStateOpen Then
' .Close
' End If
'.ActiveConnection = Cn
' .CursorLocation = adUseClient
'.CursorType = adOpenStatic
'.LockType = adLockReadOnly
'.Source = strOpen
'.Open
'End With
With Rs_Data
If .RecordCount < 1 Then
MsgBox "对不起!你的选择是错误的数据库没有记录!我想你应该不会在选择错了!", vbOKOnly + vbInformation, "提示"
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
On Error Resume Next
xlBook.SaveAs
If xlBook.Saved = True Then
MsgBox "导出成功!!文件在我的文档资料夹请另存!", vbOKOnly + vbInformation, "提示"
ElseIf xlBook.Saved = False Then
MsgBox "文件没有保存请重新导出!", vbOKOnly + vbInformation, "提示"
End If
Set xlApp = Nothing '"交还控制给Excel
Set xlBook = Nothing
Set xlSheet = Nothing
xlApp.Quit
End Function
要把excel数据库,就用二楼的就可以了。不过你的EXCEL的格式一定要标准不然不可以的哦!!
adoConnection.Open "Provider=Microsoft.Jet.OLEDB.4.0;Persist Security Info=False;Data Source=" & strFileName & ";Extended Properties='Excel 8.0;HDR=Yes'"
adoRecordset.Open "select * from [students.sheet$]", adoConnection, adOpenKeyset, adLockOptimistic
Do While Not adoRecordset.EOF
'执行你的动作
adoRecordset.MoveNext
Loop
adoRecordset.Close
adoConnection.Close
(ByVal sFile _
As String) As ADODB.Recordset On Error GoTo fix_err
Dim rs As ADODB.Recordset
Set rs = New ADODB.Recordset
Dim sconn As String rs.CursorLocation = adUseClient
rs.CursorType = adOpenKeyset
rs.LockType = adLockBatchOptimistic sconn = "DRIVER=Microsoft Excel Driver (*.xls);" & "DBQ=" & sFile
rs.Open "SELECT * FROM [sheet1$]", sconn
Set Read_Excel = rs
Set rs = Nothing
Exit Function
fix_err:
Debug.Print Err.Description + " " + _
Err.Source, vbCritical, "Import"
Err.Clear
End FunctionPrivate Sub cmdReadXLS_Click()
Set dgData.DataSource = Read_Excel(App.Path & "\" & "test.xls")
Set obj = Nothing
End Sub