CopyFromRecordset Error

[zhollywood]

OK... I'm not VBA illiterate, but I'm a BA trying to maintain a
code-heavy Access 2002 (XP OS) front-end attached to Oracle 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

*** 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

[james.igoe]

An option that has value when using Excel, given its character
limitations, is to convert the output to string using
cstr([MemoFieldName]).

Another option, if the data set is small enough, is to loop through the
recordset, pasting each Access 'cell' into each Excel cell, via code,
although the performance would be intolerable with large recordsets.
James Igoe

ja********@gmail.com || http://code.comparative-advantage.com
zhollywood wrote:

OK... I'm not VBA illiterate, but I'm a BA trying to maintain a
code-heavy Access 2002 (XP OS) front-end attached to Oracle 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

*** 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

[zhollywood]

I hate to sound stupid, but how would I incorporate your convert to
string suggestion? I might figure it out before you answer, but my
initial thought is, I have no idea what to do with it. LOL

Holly

ja********@gmail.com wrote:

An option that has value when using Excel, given its character
limitations, is to convert the output to string using
cstr([MemoFieldName]).

Another option, if the data set is small enough, is to loop through the
recordset, pasting each Access 'cell' into each Excel cell, via code,
although the performance would be intolerable with large recordsets.
James Igoe

ja********@gmail.com || http://code.comparative-advantage.com
zhollywood wrote:

OK... I'm not VBA illiterate, but I'm a BA trying to maintain a
code-heavy Access 2002 (XP OS) front-end attached to Oracle 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

*** 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