N
news.cavtel.net
I found this code and its what I need it to do except I am getting an error
(0) when I run it. I am calling the code as follows where the file name is
loan.xls and my table in my database that I want to export is Loan1a. THANKS
Any help as to why I am getting this error would be appreciated. I
referenced excel10 and DAO3.6.
Calling As Follows
***************
Dim FileName As String, MyRecs As DAO.Recordset, TestIt As Boolean
FileName = "C:\WAM\loan.xls"
Set MyRecs = CurrentDb.OpenRecordset("Loan1a")
TestIt = SaveRecordsetToExcel(MyRecs, FileName, , False)
If TestIt = True Then
MsgBox "Export Succeeded!"
Else
MsgBox "Miserable Failure!"
End If
Heres the function
**********************
Public Function SaveRecordsetToExcel(RecSet As Object, ByVal FName As
String, _
Optional Template As String = "", Optional OutRange As String =
"A1:A1", _
Optional ColumnHeaders As Boolean = True) As Boolean
Dim RSRange As Excel.Range
Dim AppExcel As Excel.Application, WkBk As Excel.Workbook, WkSht As
Excel.Worksheet, i As Integer
Dim Fld As DAO.Field
On Error GoTo ErrExit
SaveRecordsetToExcel = False
'Make sure that RecSet is a recordset
If TypeName(RecSet) = "Recordset" Then
'Create a new Excel workbook
Set AppExcel = New Excel.Application
If Template <> "" Then
Set WkBk = AppExcel.Workbooks.Add(Template)
Else
Set WkBk = AppExcel.Workbooks.Add
End If
Set WkSht = WkBk.Worksheets(1)
Set RSRange = WkSht.Range(OutRange)
'Write the column names
If ColumnHeaders Then
i = 0
For Each Fld In RecSet.Fields
RSRange.Offset(0, i).Value = Fld.Name
i = i + 1
Next
End If
'Format date columns if not writing into a template
If Template <> "" Then
i = 0
For Each Fld In RecSet.Fields
If Fld.Type = adDate Then
RSRange.Offset(0,
i).Columns(1).EntireColumn.NumberFormat = "mm/dd/yyyy hh:mm"
End If
i = i + 1
Next
End If
'Transfer the data to Excel
RSRange.Offset(1, 0).CopyFromRecordset RecSet
'Save the Workbook and Quit Excel
WkBk.SaveAs FName
AppExcel.Quit
SaveRecordsetToExcel = True
End If
Exit Function
ErrExit:
'exit with false value if failed
On Error Resume Next
MsgBox "Error(" & Err.Number & ") " & Err.Description, vbExclamation +
vbOKOnly, "Function SaveRecordsetToExcel()"
SaveRecordsetToExcel = False
AppExcel.Quit
End Function
(0) when I run it. I am calling the code as follows where the file name is
loan.xls and my table in my database that I want to export is Loan1a. THANKS
Any help as to why I am getting this error would be appreciated. I
referenced excel10 and DAO3.6.
Calling As Follows
***************
Dim FileName As String, MyRecs As DAO.Recordset, TestIt As Boolean
FileName = "C:\WAM\loan.xls"
Set MyRecs = CurrentDb.OpenRecordset("Loan1a")
TestIt = SaveRecordsetToExcel(MyRecs, FileName, , False)
If TestIt = True Then
MsgBox "Export Succeeded!"
Else
MsgBox "Miserable Failure!"
End If
Heres the function
**********************
Public Function SaveRecordsetToExcel(RecSet As Object, ByVal FName As
String, _
Optional Template As String = "", Optional OutRange As String =
"A1:A1", _
Optional ColumnHeaders As Boolean = True) As Boolean
Dim RSRange As Excel.Range
Dim AppExcel As Excel.Application, WkBk As Excel.Workbook, WkSht As
Excel.Worksheet, i As Integer
Dim Fld As DAO.Field
On Error GoTo ErrExit
SaveRecordsetToExcel = False
'Make sure that RecSet is a recordset
If TypeName(RecSet) = "Recordset" Then
'Create a new Excel workbook
Set AppExcel = New Excel.Application
If Template <> "" Then
Set WkBk = AppExcel.Workbooks.Add(Template)
Else
Set WkBk = AppExcel.Workbooks.Add
End If
Set WkSht = WkBk.Worksheets(1)
Set RSRange = WkSht.Range(OutRange)
'Write the column names
If ColumnHeaders Then
i = 0
For Each Fld In RecSet.Fields
RSRange.Offset(0, i).Value = Fld.Name
i = i + 1
Next
End If
'Format date columns if not writing into a template
If Template <> "" Then
i = 0
For Each Fld In RecSet.Fields
If Fld.Type = adDate Then
RSRange.Offset(0,
i).Columns(1).EntireColumn.NumberFormat = "mm/dd/yyyy hh:mm"
End If
i = i + 1
Next
End If
'Transfer the data to Excel
RSRange.Offset(1, 0).CopyFromRecordset RecSet
'Save the Workbook and Quit Excel
WkBk.SaveAs FName
AppExcel.Quit
SaveRecordsetToExcel = True
End If
Exit Function
ErrExit:
'exit with false value if failed
On Error Resume Next
MsgBox "Error(" & Err.Number & ") " & Err.Description, vbExclamation +
vbOKOnly, "Function SaveRecordsetToExcel()"
SaveRecordsetToExcel = False
AppExcel.Quit
End Function