Public Function getTblExcel(strExcel
As String)
On Error GoTo Create
Dim xlApp
As Excel.Application
Dim xlWbk
As Excel.Workbook
Dim xlWsh
As Excel.Worksheet
Dim Rng
As Excel.Range
Dim rsNum
As Integer
Dim rst
As New ADODB.Recordset
Dim i
As Integer
Set rst =
New ADODB.Recordset
rst.Open strExcel, CurrentProject.Connection, adOpenKeyset, adLockReadOnly
Set xlApp = GetObject(,
"Excel.Application")
xlApp.Visible =
True
Set xlWbk = xlApp.Workbooks.Add
Set xlWsh = xlWbk.Worksheets(
1)
xlWsh.Activate
Set Rng = xlWsh.Range(
"A1")
For i =
0 To rst.Fields.Count -
1
Rng.Value = rst.Fields(i).Name
Set Rng = Rng.Offset(
0,
1)
Next i
Set Rng = xlWsh.Range(
"A2")
rst.MoveFirst
Do Until rst.EOF
For i =
0 To rst.Fields.Count -
1
Rng.Value = rst.Fields(i).Value
Set Rng = Rng.Offset(
0,
1)
Next i
rst.MoveNext
Set Rng = Rng.Offset(
1, -rst.Fields.Count)
Loop
rst.Close
Set rst =
Nothing
MsgBox
"数据导出成功"
Create:
If Err =
429 Then
Set xlApp = CreateObject(
"Excel.Application")
Resume Next
End If
End Function