Dim conn As New ADODB.Connection
Dim rs As New ADODB.Recordset
Dim sql As String
Dim provider As String
Dim datasource As String
Dim Irow, Icol As Integer
Dim Irowcount, Icolcount As Integer
Dim Fieldlen()
Dim xlApp As excel.Application
Dim xlBook As excel.Workbook
Dim xlSheet As excel.Worksheet Set xlApp = CreateObject("Excel.Application")
Set xlBook = xlApp.Workbooks.Add
Set xlSheet = xlBook.Worksheets(1)provider = "provider=Microsoft.jet.oledb.4.0"
datasource = "data source=" & App.Path & "\图书管理数据.mdb"
conn.Open provider & ";" & datasource
sql = "select * from 借阅信息 where 还书日期 is not null"
rs.Open sql, conn, adOpenKeyset, adLockOptimisticIf rs.RecordCount = 0 Then
MsgBox "借阅信息为空!", vbOKOnly + vbExclamation
rs.Close
xlBook.Close
Set xlApp = Nothing
Set xlBook = Nothing
Set xlSheet = Nothing
Exit Sub
End If
Irowcount = rs.RecordCount
Icolcount = rs.Fields.Count ReDim Fieldlen(Icolcount)
rs.MoveFirst
'设置单元格式
xlSheet.Cells.Select
Selection.NumberFormatLocal = "@"
'开始插入数据
For Irow = 1 To Irowcount + 1
For Icol = 1 To Icolcount
Select Case Irow
Case 1
xlSheet.Cells(Irow, Icol).Value = rs.Fields(Icol - 1).Name
Case 2
If IsNull(rs.Fields(Icol - 1)) = True Then
Fieldlen(Icol) = LenB(rs.Fields(Icol - 1).Name)
Else
Fieldlen(Icol) = LenB(rs.Fields(Icol - 1))
End If
xlSheet.Columns(Icol).ColumnWidth = CStr(Fieldlen(Icol))
xlSheet.Cells(Irow, Icol).Value = CStr(rs.Fields(Icol - 1))
Case Else
Fieldlen1 = LenB(rs.Fields(Icol - 1))
If Fieldlen(Icol) < Fieldlen1 Then
xlSheet.Columns(Icol).ColumnWidth = Fieldlen1
Fieldlen(Icol) = Fieldlen1
Else
xlSheet.Columns(Icol).ColumnWidth = CStr(Fieldlen(Icol))
End If
xlSheet.Cells(Irow, Icol).Value = CStr(rs.Fields(Icol - 1) & " ")
End Select
Next Next
xlSheet.Range(xlSheet.Cells(1, 1), xlSheet.Cells(1, Icol - 1)).Font.Name = "黑体"
xlSheet.Range(xlSheet.Cells(1, 1), xlSheet.Cells(1, Icol - 1)).Font.Bold = True
xlSheet.Range(xlSheet.Cells(1, 1), xlSheet.Cells(Irow, Icol - 1)).Borders.LineStyle = xlContinuous
xlApp.Visible = True
xlBook.Save
Set xlApp = Nothing
Set xlBook = Nothing
Set xlSheet = Nothing
rs.Close
Erro:
If Err.Number <> 0 Then
MsgBox "借阅信息导出失败", vbOKOnly + vbExclamation
End If导出失败后!进程就能关掉了!还有导出一次成功后,第二次就报错为变量未设置!
Dim rs As New ADODB.Recordset
Dim sql As String
Dim provider As String
Dim datasource As String
Dim Irow, Icol As Integer
Dim Irowcount, Icolcount As Integer
Dim Fieldlen()
Dim xlApp As excel.Application
Dim xlBook As excel.Workbook
Dim xlSheet As excel.Worksheet Set xlApp = CreateObject("Excel.Application")
Set xlBook = xlApp.Workbooks.Add
Set xlSheet = xlBook.Worksheets(1)provider = "provider=Microsoft.jet.oledb.4.0"
datasource = "data source=" & App.Path & "\图书管理数据.mdb"
conn.Open provider & ";" & datasource
sql = "select * from 借阅信息 where 还书日期 is not null"
rs.Open sql, conn, adOpenKeyset, adLockOptimisticIf rs.RecordCount = 0 Then
MsgBox "借阅信息为空!", vbOKOnly + vbExclamation
rs.Close
xlBook.Close
Set xlApp = Nothing
Set xlBook = Nothing
Set xlSheet = Nothing
Exit Sub
End If
Irowcount = rs.RecordCount
Icolcount = rs.Fields.Count ReDim Fieldlen(Icolcount)
rs.MoveFirst
'设置单元格式
xlSheet.Cells.Select
Selection.NumberFormatLocal = "@"
'开始插入数据
For Irow = 1 To Irowcount + 1
For Icol = 1 To Icolcount
Select Case Irow
Case 1
xlSheet.Cells(Irow, Icol).Value = rs.Fields(Icol - 1).Name
Case 2
If IsNull(rs.Fields(Icol - 1)) = True Then
Fieldlen(Icol) = LenB(rs.Fields(Icol - 1).Name)
Else
Fieldlen(Icol) = LenB(rs.Fields(Icol - 1))
End If
xlSheet.Columns(Icol).ColumnWidth = CStr(Fieldlen(Icol))
xlSheet.Cells(Irow, Icol).Value = CStr(rs.Fields(Icol - 1))
Case Else
Fieldlen1 = LenB(rs.Fields(Icol - 1))
If Fieldlen(Icol) < Fieldlen1 Then
xlSheet.Columns(Icol).ColumnWidth = Fieldlen1
Fieldlen(Icol) = Fieldlen1
Else
xlSheet.Columns(Icol).ColumnWidth = CStr(Fieldlen(Icol))
End If
xlSheet.Cells(Irow, Icol).Value = CStr(rs.Fields(Icol - 1) & " ")
End Select
Next Next
xlSheet.Range(xlSheet.Cells(1, 1), xlSheet.Cells(1, Icol - 1)).Font.Name = "黑体"
xlSheet.Range(xlSheet.Cells(1, 1), xlSheet.Cells(1, Icol - 1)).Font.Bold = True
xlSheet.Range(xlSheet.Cells(1, 1), xlSheet.Cells(Irow, Icol - 1)).Borders.LineStyle = xlContinuous
xlApp.Visible = True
xlBook.Save
Set xlApp = Nothing
Set xlBook = Nothing
Set xlSheet = Nothing
rs.Close
Erro:
If Err.Number <> 0 Then
MsgBox "借阅信息导出失败", vbOKOnly + vbExclamation
End If导出失败后!进程就能关掉了!还有导出一次成功后,第二次就报错为变量未设置!
If Err.Number <> 0 Then
MsgBox "借阅信息导出失败", vbOKOnly + vbExclamation
End If==>Erro:
If Err.Number <> 0 ThenSet xlApp = Nothing
Set xlBook = Nothing
Set xlSheet = Nothing
MsgBox "借阅信息导出失败", vbOKOnly + vbExclamation
End If
.
.
' Close Excel.
excel_app.Quit
Set excel_app = Nothing MsgBox "导出成功"
Exit SubmyErr:
If Err.Number = 429 Then
Screen.MousePointer = vbDefault
MsgBox "请先安装EXCEL!", , "导出错误"
Exit Sub
End If
excel_app.DisplayAlerts = False
excel_app.Quit '关闭EXCEL
excel_app.DisplayAlerts = True
Set excel_app = Nothing
MsgBox "导出出错"
End Sub