Public Function AccessToExcel(ByVal TempSql As String, Optional TempName As String)
'数据导出到Excel
'tempsql:支持sql语句\查询\表
'tempName:导出Excel的工作表的名称
'注意必须引用excel对象
On Error GoTo Err:
Dim row As Integer
Dim col As Integer
Dim Conn As ADODB.Connection
Dim Rs As ADODB.Recordset
Dim sql As String
Dim ExcelApp As Excel.Application
Dim ExcelWst As Worksheet ''excel窗体
Dim RsCount As Integer ''记录数
Set Conn = CurrentProject.Connection '''本地连接
If TempSql = "" Then Exit Function
' sql = TempSql ' "select * from 书本"
Set Rs = CreateObject("ADODB.Recordset")
Rs.Open TempSql, Conn, 1 ' 1 = adOpenKeyset
Set ExcelApp = New Excel.Application
Set ExcelWst = ExcelApp.Workbooks.Add.Worksheets(1)
ExcelWst.Name = TempName
For col = 0 To Rs.Fields.Count - 1
ExcelWst.Cells(1, col + 1) = Rs.Fields(col).Name
Next
row = 2
RsCount = Rs.RecordCount
Rs.MoveFirst
While Not Rs.EOF
For col = 0 To Rs.Fields.Count - 1
ExcelWst.Cells(row, col + 1) = Rs.Fields(col)
''转换日期型字符的表示格式
If Rs.Fields(col).Type = 7 Then
ExcelWst.Cells(row, col + 1).NumberFormatLocal = "yyyy-m-d;@"
End If
Next
row = row + 1
Rs.MoveNext
Wend
Rs.Close
Set Rs = Nothing
Set Conn = Nothing
ExcelApp.Visible = True
Err:
Exit Function
End Function