mathguy1433
Technical User
Hello,
I am building some code to send emails with attachments to clients, so I am copying recordsets to excel sheets and then sending the excel file to them. Basically every record in the recordset correlates to an attached email.
Essentially I continue to get this error, "Run-time error '-2147417856 (80010100)' Method 'CopyFromRecordset' of object 'Range' failed" when trying to copy from a recordset to my excel file range. The bizarre thing is that if I click debug and continue running the code, the data actually copies correctly and it does exactly what needs to happen. But if I add an error line on error resume next, the copyfromrecordset method does absolutely nothing and my files send out as blank. I could really use any help anyone could suggest.
I should quickly add that the first 5 or so records of the task work perfectly fine everytime then it starts to error out randomly on the copyfromrecordset lines.
sample code: (I removed the non relevant Dim's as well as most of the code that occurs after the copyfromrecordset
Option Compare Database
Public Function AllReportsEmailTest()
Dim OutputFolder As String
Dim xlApp As Excel.Application
Dim wb As Excel.Workbook
Dim wb1, wb2, wb3, wb4 As Excel.Workbook
Dim ws As Excel.Worksheet
Dim ws1, ws2, ws3, ws4 As Excel.Worksheet
Dim MyDB As DAO.Database
Dim RS As DAO.Recordset
Dim tsql, Csql, rsql As String
Dim SavedExcelSheet As String
Dim rsqry, rsqry1, rsqry2, rsqry3, rsqry4, rsqry5, rsqry6, rsqry7, rsqry8, rsqry9, rsqry10, rsqry11, rsqry12, rsqry13, rsqry14, rsqry15, rsqry16, rsqry17, rsqry18, rsqry19, rsqry20 As DAO.Recordset
ReportName = "qryReportCard"
sourcename = "S:\Old Report Cards\" & ReportName
OutputFolder = "S:\PDF File"
qry = "qryReportCard"
Set MyDB = CurrentDb
Set RS = MyDB.OpenRecordset(qry)
RS.MoveLast
RS.MoveFirst
Set objOutlook = CreateObject("Outlook.Application")
'r is used to match individual records with email attachment
r = 2
q = 0
Do While Not RS.EOF
If IsNull(DLookup("[Email Address]", qry, "[Email Address] = '" & RS![Email Address] & "'")) Then GoTo phase2
If IsNull(DLookup("[MemberID]", qry, "[MemberID] = '" & RS![MemberID] & "'")) Then GoTo phase2
Set objOutlookMsg = objOutlook.CreateItem(olMailItem)
TheAddress = RS![TestEmailAddress]
With objOutlookMsg
' Add the To recipients to the e-mail message.
Set objOutlookRecip = .Recipients.Add(TheAddress)
objOutlookRecip.Type = olTo
Set objOutlookRecip = .Recipients.Add("email")
objOutlookRecip.Type = olBCC
Set rsqry = MyDB.OpenRecordset("SELECT * From qryReportCard Where MemberID = '" & RS![MemberID] & "'", dbOpenDynaset)
Set rsqry1 = MyDB.OpenRecordset("SELECT * FROM qryGapReport Where MemberID = '" & RS![MemberID] & "'", dbOpenDynaset)
Set rsqry2 = MyDB.OpenRecordset("SELECT [Measure Name], [Measure Code], [Measure Description] FROM tblGapMetrics", dbOpenDynaset)
Set rsqry3 = MyDB.OpenRecordset("SELECT * FROM qryRiskReport Where MemberID = '" & RS![MemberID] & "'", dbOpenDynaset)
' ..... there are more (but you get the picture)
strnpi = RS![MemberID]
Set xlApp = CreateObject("Excel.Application")
xlApp.ScreenUpdating = False
Set wb = xlApp.Workbooks.Open(OutputFolder & "\" & SavedExcelSheet & ".xlsx")
wb.Worksheets("DataInput").Range("B2").CopyFromRecordset rsqry
with xlApp
[highlight yellow] wb.Worksheets("MemberRiskReport").Range("A2").CopyFromRecordset rsqry3[/highlight] (where error occurs)
wb.Worksheets("Service").Range("K7").CopyFromRecordset rsqry4
wb.Worksheets("GapReport").Range("A2").CopyFromRecordset rsqry1
wb.Worksheets("GapMetrics").Range("A2").CopyFromRecordset rsqry2
'...
wb.SaveAs (OutputFolder & "\" & SavedExcelSheet & " " & RS![MemberID] & ".xlsx")
wb.SaveAs ("S:\Provider Relations\NexUS\NexUS DB\NexUS Scorecard Backups\" & "NexUS Scorecards " & datetime1 & " " & RS![MemberID] & ".xlsx")
wb.Close
xlApp.Workbooks.Close
xlApp.Quit
xlApp.DisplayAlerts = True
xlApp.Visible = False
Set xlApp = Nothing
Set wb = Nothing
End With
If Not IsMissing(OutputFolder & "\" & SavedExcelSheet & " " & RS![MemberID] & ".xlsx") Then
Set objOutlookAttach = .Attachments.Add(OutputFolder & "\" & SavedExcelSheet & " " & RS![MemberID] & ".xlsx")
End If
Kill OutputFolder & "\" & SavedExcelSheet & " " & RS![MemberID] & ".xlsx"
MyDB.QueryDefs.Delete ("GraphGeneration")
' Resolve the name of each Recipient.
For Each objOutlookRecip In .Recipients
objOutlookRecip.Resolve
If Not objOutlookRecip.Resolve Then
objOutlookMsg.Display
End If
Next
.Send
'.Send .display to see them if you want to auto send it
End With
rsqry.Close
rsqry1.Close
rsqry2.Close
rsqry3.Close
phase2:
RS.MoveNext
r = r + 1
Loop
MyRS.Close
t = Nothing
v = Nothing
Set objOutlookMsg = Nothing
Set objOutlook = Nothing
End Function
I am building some code to send emails with attachments to clients, so I am copying recordsets to excel sheets and then sending the excel file to them. Basically every record in the recordset correlates to an attached email.
Essentially I continue to get this error, "Run-time error '-2147417856 (80010100)' Method 'CopyFromRecordset' of object 'Range' failed" when trying to copy from a recordset to my excel file range. The bizarre thing is that if I click debug and continue running the code, the data actually copies correctly and it does exactly what needs to happen. But if I add an error line on error resume next, the copyfromrecordset method does absolutely nothing and my files send out as blank. I could really use any help anyone could suggest.
I should quickly add that the first 5 or so records of the task work perfectly fine everytime then it starts to error out randomly on the copyfromrecordset lines.
sample code: (I removed the non relevant Dim's as well as most of the code that occurs after the copyfromrecordset
Option Compare Database
Public Function AllReportsEmailTest()
Dim OutputFolder As String
Dim xlApp As Excel.Application
Dim wb As Excel.Workbook
Dim wb1, wb2, wb3, wb4 As Excel.Workbook
Dim ws As Excel.Worksheet
Dim ws1, ws2, ws3, ws4 As Excel.Worksheet
Dim MyDB As DAO.Database
Dim RS As DAO.Recordset
Dim tsql, Csql, rsql As String
Dim SavedExcelSheet As String
Dim rsqry, rsqry1, rsqry2, rsqry3, rsqry4, rsqry5, rsqry6, rsqry7, rsqry8, rsqry9, rsqry10, rsqry11, rsqry12, rsqry13, rsqry14, rsqry15, rsqry16, rsqry17, rsqry18, rsqry19, rsqry20 As DAO.Recordset
ReportName = "qryReportCard"
sourcename = "S:\Old Report Cards\" & ReportName
OutputFolder = "S:\PDF File"
qry = "qryReportCard"
Set MyDB = CurrentDb
Set RS = MyDB.OpenRecordset(qry)
RS.MoveLast
RS.MoveFirst
Set objOutlook = CreateObject("Outlook.Application")
'r is used to match individual records with email attachment
r = 2
q = 0
Do While Not RS.EOF
If IsNull(DLookup("[Email Address]", qry, "[Email Address] = '" & RS![Email Address] & "'")) Then GoTo phase2
If IsNull(DLookup("[MemberID]", qry, "[MemberID] = '" & RS![MemberID] & "'")) Then GoTo phase2
Set objOutlookMsg = objOutlook.CreateItem(olMailItem)
TheAddress = RS![TestEmailAddress]
With objOutlookMsg
' Add the To recipients to the e-mail message.
Set objOutlookRecip = .Recipients.Add(TheAddress)
objOutlookRecip.Type = olTo
Set objOutlookRecip = .Recipients.Add("email")
objOutlookRecip.Type = olBCC
Set rsqry = MyDB.OpenRecordset("SELECT * From qryReportCard Where MemberID = '" & RS![MemberID] & "'", dbOpenDynaset)
Set rsqry1 = MyDB.OpenRecordset("SELECT * FROM qryGapReport Where MemberID = '" & RS![MemberID] & "'", dbOpenDynaset)
Set rsqry2 = MyDB.OpenRecordset("SELECT [Measure Name], [Measure Code], [Measure Description] FROM tblGapMetrics", dbOpenDynaset)
Set rsqry3 = MyDB.OpenRecordset("SELECT * FROM qryRiskReport Where MemberID = '" & RS![MemberID] & "'", dbOpenDynaset)
' ..... there are more (but you get the picture)
strnpi = RS![MemberID]
Set xlApp = CreateObject("Excel.Application")
xlApp.ScreenUpdating = False
Set wb = xlApp.Workbooks.Open(OutputFolder & "\" & SavedExcelSheet & ".xlsx")
wb.Worksheets("DataInput").Range("B2").CopyFromRecordset rsqry
with xlApp
[highlight yellow] wb.Worksheets("MemberRiskReport").Range("A2").CopyFromRecordset rsqry3[/highlight] (where error occurs)
wb.Worksheets("Service").Range("K7").CopyFromRecordset rsqry4
wb.Worksheets("GapReport").Range("A2").CopyFromRecordset rsqry1
wb.Worksheets("GapMetrics").Range("A2").CopyFromRecordset rsqry2
'...
wb.SaveAs (OutputFolder & "\" & SavedExcelSheet & " " & RS![MemberID] & ".xlsx")
wb.SaveAs ("S:\Provider Relations\NexUS\NexUS DB\NexUS Scorecard Backups\" & "NexUS Scorecards " & datetime1 & " " & RS![MemberID] & ".xlsx")
wb.Close
xlApp.Workbooks.Close
xlApp.Quit
xlApp.DisplayAlerts = True
xlApp.Visible = False
Set xlApp = Nothing
Set wb = Nothing
End With
If Not IsMissing(OutputFolder & "\" & SavedExcelSheet & " " & RS![MemberID] & ".xlsx") Then
Set objOutlookAttach = .Attachments.Add(OutputFolder & "\" & SavedExcelSheet & " " & RS![MemberID] & ".xlsx")
End If
Kill OutputFolder & "\" & SavedExcelSheet & " " & RS![MemberID] & ".xlsx"
MyDB.QueryDefs.Delete ("GraphGeneration")
' Resolve the name of each Recipient.
For Each objOutlookRecip In .Recipients
objOutlookRecip.Resolve
If Not objOutlookRecip.Resolve Then
objOutlookMsg.Display
End If
Next
.Send
'.Send .display to see them if you want to auto send it
End With
rsqry.Close
rsqry1.Close
rsqry2.Close
rsqry3.Close
phase2:
RS.MoveNext
r = r + 1
Loop
MyRS.Close
t = Nothing
v = Nothing
Set objOutlookMsg = Nothing
Set objOutlook = Nothing
End Function