CopyFromRecordset Error

[zhollywood]

OK... I'm not VBA illiterate, but I'm a BA trying to maintain a code-heavy
Access front-end attached to Oracles tables. I have an export to Excel
button that worked before the SP2 upgrade, and didn't work afterwards.
Research shows me the upgrade caused a problem with a memo field in the
export, causing the CopyFromRecordset of object Range error. I found code
that is supposed to fix it, but it either doesn't work, or I'm not using it
correctly. Here is the code I started with:

Function exportVarianceExplanations()

Dim filename As String
Dim directory As String
Dim filepath As String
Dim i As Integer

Dim RS As ADODB.Recordset
Dim objXL As Excel.Application
Dim objWkb As Excel.Workbook
Dim objSht As Excel.Worksheet


Dim intMaxCol As Integer
Dim intMaxRow As Integer

Call progressform("open", "Connecting to database...", 0, _
DIALOG_TITLE, "accessdb")

ConnectSource "EXPNSUSR.VAREXPLNREPORT", "varexplnreport"


filename = "Variance Explanations " &
getApplicationVariable("varexplnmonth") & _
getApplicationVariable("varexplnyear")
directory = GetSpecialfolder(CSIDL_PERSONAL)

filepath = directory & filename & ".xls"


i = 0
Do Until Dir(filepath) = ""
i = i + 1
filepath = GetSpecialfolder(CSIDL_PERSONAL) & filename & " " & i &
".xls"
Loop

filename = filepath

Call progressform("close", "", 0, _
DIALOG_TITLE, "")

Call progressform("open", "Retrieving variance explanations...", 0, _
DIALOG_TITLE, "extractrecords")

SQL = "SELECT * FROM VAREXPLNREPORT "

If intRole <> 6 And intRole <> 2 Then
SQL = SQL & "WHERE BUDGET_CENTER IN (" & _
"SELECT fldBudgetCenter FROM tblRightsBudgetCenter " & _
"WHERE fldUserName = '" & strUserName & "')"
End If

Debug.Print SQL

Set RS = New ADODB.Recordset
RS.Open (SQL), CurrentProject.Connection, adOpenStatic, adLockReadOnly,
adAsyncFetch


Set objXL = CreateObject("Excel.Application")

With objXL
.Visible = False
Set objWkb = .Workbooks.Add

RS.MoveLast
intMaxRow = RS.AbsolutePosition
RS.MoveFirst
intMaxCol = RS.Fields.Count

Call progressform("close", "", 0, DIALOG_TITLE, "")

Call progressform("open", RS.RecordCount & " records
retrieved...", 500, _
DIALOG_TITLE, "exceltransfer")

Set objSht = objWkb.Worksheets.Add
objSht.Name = "Variance Explanations"

Call progressform("other", "Transferring records to Excel
worksheet...", _
1500, DIALOG_TITLE, "exceltransfer")

With objSht
For i = 1 To intMaxCol
.Cells(1, i).Value = RS.Fields(i - 1).Name
Next i

*** Error Debug brings me to the line below***
.Range(.Cells(2, 1), .Cells(intMaxRow,
intMaxCol)).CopyFromRecordset RS

End With


objSht.Rows("1:1").Select

With .selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.ShrinkToFit = False
.MergeCells = False
End With

.ActiveSheet.Range(.Cells(1, 1), .Cells(1, intMaxCol)).Select

Call progressform("other", "Formatting Excel worksheet...",
1500, _
DIALOG_TITLE, "exceltransfer")

With .selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With

With .selection.Interior
.ColorIndex = 15
.Pattern = xlSolid
End With

.ActiveSheet.Columns("K:M").Select
.selection.NumberFormat = "#,##0.00_);[Red](#,##0.00)"

.ActiveSheet.Columns("I:I").Select
.selection.ColumnWidth = 55
With .selection
.WrapText = True
.Orientation = 0
.ShrinkToFit = False
.MergeCells = False
End With

.ActiveSheet.Columns("J:J").Select
.selection.NumberFormat = "mm/dd/yyyy"

.ActiveSheet.Cells(1, 1).Select

.ActiveSheet.Cells.Select
With .selection.Font
.Name = "Arial"
.Size = 8
End With

.selection.VerticalAlignment = xlTop

.selection.Columns.AutoFit

End With

Call progressform("other", "Saving File...", 1500, _
DIALOG_TITLE, "exceltransfer")

objXL.Application.DisplayAlerts = False

For Each objSht In objWkb.Sheets
If objSht.Name Like "*Sheet*" Then
objSht.Delete
End If
Next

objXL.Application.DisplayAlerts = True

objWkb.SaveAs filepath, xlWorkbookNormal, , , , , xlNoChange, , True
objXL.Quit
Set objSht = Nothing
Set objWkb = Nothing
Set objXL = Nothing

RemoveSource "varexplnreport"


Call progressform("close", "Query results export completed.", _
0, DIALOG_TITLE, "exceltransfer")

MsgBox "Your file has been exported to " & filepath & ".",
vbInformation, DIALOG_TITLE

End Function

Code I found for the "fix", with my modifications included:

i = 1
For Each RS In RS.Fields
objSht.Cells(2, i).Value = RS.Name
i = i + 1
Next RS

Dim j As Long, k As Long

With objSht
For j = 1 To RS.RecordCount
For k = 1 To RS.Fields.Count
If IsNull(RS(k - 1)) Then
.Cells(j + 2, k) = Empty
Else
If Len(RS(k - 1)) > 255 Then
For i = 0 To Int(Len(RS(k - 1)) / 255)
.Cells(j + 2, k).Value = .Cells(j + 2,
k).Value & Mid(RS(k - 1),
(i * 255) + 1, 255)
Next i
Else
.Cells(j + 2, k).Value = RS(k - 1)
End If
End If
Next k
RS.MoveNext
Next j
End With

ARGH! Help, PLEASE! Bypassing the memo field is NOT an option. It is the
main reason for the export.

Thanks,
zhollywood