Splitting a report into separate emails with their individual reports - ms-access

Question

I am trying to send separate Employees a PDF/page of their section/report. The information is based on their EmployeeID (which is text not long number). So each person has their balance information on a page then there's a page break, and then next page shows the next person's details. With the code below, it does email each of the employees one page but it so happens to only email the first person's page to EVERYONE. Is it possible to somehow automate each week so that each user is emailed his/her individual page of the report?
Another error is that the email pop up one by one so I have to press send each time for over 200 people, and that the email seems to be sending to the email but then followed by #mailto:the email# for example email#email.com#mailto:email#email.com#
I just started Access and have been copying and scraping code off of places I have found online. Many thanks in advance, if you can assist!
Have a great day!
Private Sub cmdSendAll_Click()
Dim rsAccountNumber As DAO.Recordset
Dim strTo As Variant
Dim strSubject As String
Dim strMessageText As String
Set rsAccountNumber = CurrentDb.OpenRecordset("SELECT DISTINCT EmployeeID, [Email] FROM [queAutoUpdate]", dbOpenSnapshot)
Debug.Print strTo
With rsAccountNumber
Do Until .EOF
DoCmd.OpenReport "test", _
acViewPreview, _
WhereCondition:="EmployeeID = '" & !EmployeeID & "'", _
WindowMode:=acHidden
strTo = ![Email]
strSubject = "Updated Balance "
strMessageText = "Text Here"
DoCmd.SendObject ObjectType:=acSendReport, _
ObjectName:="test", _
OutputFormat:=acFormatPDF, _
To:=strTo, _
Subject:=strSubject, _
MESSAGETEXT:=strMessageText, _
EditMessage:=True
DoCmd.Close acReport, "Unaffirmed Report", acSaveNo
.MoveNext
Loop
.Close
End With
End Sub

Answer 1

Your opening a report called test and then closing another report called "Unaffirmed Report". You need to open and close the same report, in this case "test".
DoCmd.Close acReport, "test", acSaveNo. This should fix the employee data not updating, since the report remains open on the first employee.
To directly send the message you need change EditMessage:=True to EditMessage:=False.
Check the docs:
https://learn.microsoft.com/en-us/office/vba/api/access.docmd.sendobject
Also if you need to test this, set outlook in Offline mode, and run your code, check the messages in your Outbox to see if they're as expected. You can delete the messages from the Outbox to prevent them from being sent. Once you're finished with testing you can set Outlook back to Online Mode.
Regarding the email address issue, this comes automatically when using hyperlinks in your controls. You'll need to strip the extra part out with strTo = Left(![Email],InStr(![Email],"#")-1). Check your data if this will be valid for all email addresses. For a more advanced solution you can look at this post https://codekabinett.com/rdumps.php?Lang=2&targetDoc=access-hyperlink-data-type.
Code provided as reference, please see the post for the explanation.
'copied from https://codekabinett.com/rdumps.php?Lang=2&targetDoc=access-hyperlink-data-type
Public Function GetHyperlinkFullAddress(ByVal hyperlinkData As Variant, Optional ByVal removeMailto As Boolean) As Variant
Const SEPARATOR As String = "#"
Dim retVal As Variant
Dim tmpArr As Variant
If IsNull(hyperlinkData) Then
retVal = hyperlinkData
Else
If InStr(hyperlinkData, SEPARATOR) > 0 Then
' I append 4 separators at the end, so I don't have to worry about the
' lenght of the array returned by Split()
hyperlinkData = hyperlinkData & String(4, SEPARATOR)
tmpArr = Split(hyperlinkData, SEPARATOR)
If Len(tmpArr(1)) > 0 Then
retVal = tmpArr(1)
If Len(tmpArr(2)) > 0 Then
retVal = retVal & "#" & tmpArr(2)
End If
End If
Else
retVal = hyperlinkData
End If
If Left(retVal, 7) = "mailto:" Then
retVal = Mid(retVal, 8)
End If
End If
GetHyperlinkFullAddress = retVal
End Function

Answer 2

Consider using the MS Outlook object library to send emails. Whereas DoCmd.SendObject is a convenience handler, you control more of the process with initializing an Outlook application object and creating an Outlook email object setting all needed elements.
However, with this approach you need to first export your filtered report to PDF and then attach to email for final send. See inline comments for specific details.
Dim rsAccountNumber As DAO.Recordset
' CHECK Microsoft Outlook #.# Object Library UNDER Tools/References
Dim olApp As Outlook.Application, olEmail As Outlook.MailItem
Dim fileName As string, todayDate As String, strEmail As String
todayDate = Format(Date, "YYYY-MM-DD")
Set rsAccountNumber = CurrentDb.OpenRecordset("SELECT DISTINCT EmployeeID, [Email] FROM [queAutoUpdate]", dbOpenSnapshot)
Set olApp = New Outlook.Application
With rsAccountNumber
Do Until .EOF
' SETTING FILE NAME TO SAME PATH AS DATABASE (ADJUST AS NEEDED)
fileName = Application.CurrentProject.Path & "\Balance_Report_" & !EmployeeID & "_" & todayDate & ".pdf"
' OPEN AND EXPORT PDF TO FILE
DoCmd.OpenReport "test", acViewPreview, "EmployeeID = '" & !EmployeeID & "'"
' INTENTIONALLY LEAVE REPORT NAME BLANK FOR ABOVE FILTERED REPORT
DoCmd.OutputTo acReport, , acFormatPDF, fileName, False
DoCmd.Close acReport, "test"
' CREATE EMAIL OBJECT
strEmail = ![Email]
Set olEmail = olApp.CreateItem(olMailItem)
With olEmail
.Recipients.Add strEmail
.Subject = "Updated Balance"
.Body = "Text Here"
.Attachments.Add fileName ' ATTACH PDF REPORT
.Send ' SEND WITHOUT DISPLAY TO SCREEN
End With
Set olEmail = Nothing
.MoveNext
Loop
.Close
End With
MsgBox "All emails successfully sent!", vbInformation, "EMAIL STATUS"
Set rsAccountNumber = Nothing: Set olApp = Nothing