access导出MySQL表格_如何将Access数据库里的表内容导出到Excel

Public Function ExporToExcel(strOpen As String)

'*********************************************************

'* 名称：ExporToExcel

'* 功能：导出数据到EXCEL

'* 用法：ExporToExcel(sql查询字符串)

'*********************************************************

Dim Rs_Data As New ADODB.Recordset

Dim Irowcount As Integer

Dim Icolcount As Integer

StbInfo ("正在联系EXCEL,准备创建并定义工作表...")

Dim xlApp As New Excel.Application

Dim xlBook As Excel.Workbook

Dim xlSheet As Excel.Worksheet

Dim xlQuery As Excel.QueryTable

On Error Resume Next

With Rs_Data

If .State = adStateOpen Then

.Close

End If

.ActiveConnection = cn

.CursorLocation = adUseClient

.CursorType = adOpenStatic

.LockType = adLockReadOnly

.Source = strOpen

.Open

End With

StbInfo ("正在向excel的工作表中添加数据...请稍候...")

With Rs_Data

If .RecordCount < 1 Then

MsgBox "没有记录可以导出，请确认数据源记录是否为空!", 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("a2"))

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 + 1)).Font.Name = "微软雅黑"

.Range(.Cells(1, 1), .Cells(1, Icolcount)).Font.Size = 14

.Range(.Cells(1, 2), .Cells(1, Icolcount)).Font.Bold = True

'.Range(.Cells(1, 1), .Cells(Irowcount + 1, Icolcount + 1)).Font.Size = 10

.Columns.Width = 300

'标题字体加粗

.Range(.Cells(2, 1), .Cells(Irowcount + 2, Icolcount)).Borders.LineStyle = xlContinuous

.Range(.Cells(2, 1), .Cells(Irowcount + 2, Icolcount)).Font.Name = "微软雅黑"

.Range(.Cells(2, 1), .Cells(Irowcount + 2, Icolcount)).Font.Size = 9

'.Range(.Cells(2, 1), .Cells(Irowcount + 2, Icolcount)).Font.Color = vbRed

'设表格边框样式

End With

If CirPickPlt = False Then

xlSheet.Cells(1, 1) = XlsTitle  '自定义表头

End If

xlApp.Application.Visible = True

If Prt = True Then xlApp.Worksheets.PrintPreview

xlApp.DisplayAlerts = False

Set xlApp = Nothing  '"交还控制给Excel

Set xlBook = Nothing

Set xlSheet = Nothing

xlApp.Quit

End Function