Do While Not rs.EOF '
temp = rs("AGENT")
MyFileName = rs("AGENT")
attach = mypath & MyFileName & ".pdf"
strEMail = rs![Email] & ";"
'
DoCmd.OpenReport "R1099", acViewReport, , "[AGENT]='" & temp & "'"
DoCmd.OutputTo acOutputReport, "", acFormatPDF, attach
DoCmd.Close acReport, "R1099"
DoEvents
'
With oMail
.To = Left$(strEMail, Len(strEMail) - 1)
.Body = "With the end of 2022 approaching, we are looking to get a jump on year end 1099 preparation. Please review the attached information and let us know if any corrections are required." & vbCrLf & "Thanks," & vbCrLf & "Accounting"
.Subject = MyFileName & " Tax Information"
.Attachments.Add attach
.Display
End With
obj.SendUsingAc count function - I've not used it myself in the Access environment; however, I have used it in the Outlook environment ( Microsoft Function: outlook.mailite m.sendusingacco unt ) I'm sure there's a way to use this in the Access VBA - might have to either late-bind or add the reference to the Microsoft Outlook object library.
Dim OutApp As Object
Dim objAccount As Object
Dim objMail As Object
Dim intCtr As Integer
Set OutApp = CreateObject("Outlook.Application")
For intCtr = 1 To OutApp.Session.Accounts.Count
If OutApp.Session.Accounts.Item(intCtr) = "info@abccompany.com" Then
Set objAccount = OutApp.Session.Accounts.Item(intCtr)
Set objMail = OutApp.CreateItem(0)
With objMail
.Subject = "Some Subject"
.Body = "Body Text here"
.To = "someone@somewhere.com"
.SendUsingAccount objAccount
.Send
End With
End If
Next
Option Compare Database
Option Explicit
Sub SendUsing_LateBindMethod_Click()
'Use following Dim statements for Late Binding
'NOTE: Additional Const declaration
Const olMailItem As Long = 0 'For Late Binding
Const olFolderInbox As Long = 6 'For Late Binding
Const olFormatHTML As Long = 2 'For Late Binding
Dim objOutlook As Object 'Outlook.Application '(Note dimensioned as Object)
Dim objEmail As Object 'Outlook.MailItem '(Note dimensioned as Object)
Dim objNameSpace As Object 'Outlook.NameSpace '(Note dimensioned as Object)
Dim objFindAccount As Object 'Outlook.Account Temporary object to find the correct account object
Dim strFromSmtpAddress As String
Dim strSubject As String
Dim strToAddress As String
Dim strBodyText As String
On Error GoTo zErrorTrap
'
' Just a place to put this information
strSubject = "My Test Message - testing sendusingaccount property"
strToAddress = "BogusToEmail@TrashMail.com"
strFromSmtpAddress = "BogusSMTPEmail@TrashMail.com"
strBodyText = "Lorem ipsum dolor sit amet, consectetur adipiscing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua."
'
' Late bind to the outlook application - may not work for Outlook365 - must have desktop version
Set objOutlook = GetObject(, "Outlook.Application")
'
' Hook to the currently running outlook application session or create a new session
If objOutlook Is Nothing Then
Set objOutlook = CreateObject("Outlook.Application")
Set objNameSpace = objOutlook.GetNamespace("MAPI")
objNameSpace.GetDefaultFolder(olFolderInbox).Display
End If
'
' Create a new mail item
Set objEmail = objOutlook.CreateItem(olMailItem)
'
' Find the SMPT account in the curent session that you want to send from if not the default account
If Len(strFromSmtpAddress) > 0 Then
For Each objFindAccount In objOutlook.Session.Accounts
If objFindAccount.SmtpAddress = strFromSmtpAddress Then
Set objEmail.SendUsingAccount = objFindAccount
End If
Next
End If
'
' Start the email and send (note there are alot of options here - this are the basics)
With objEmail
.To = strToAddress
.Subject = strSubject
.BodyFormat = olFormatHTML
.Body = strBodyText
'
'uncomment to show the email and allow the user to edit before sending.
.Display
'
'comment out display to send without visual
'.Send
'
End With
'
'clean up the memory
zRecover:
If Not objFindAccount Is Nothing Then Set objFindAccount = Nothing
If Not objOutlook Is Nothing Then Set objOutlook = Nothing
If Not objEmail Is Nothing Then Set objOutlook = Nothing
If Not objNameSpace Is Nothing Then Set objOutlook = Nothing
Exit Sub
zErrorTrap:
'Stop
Select Case Err.Number
Case 429
'no current outlook object resume the code and create an object
Resume Next
Case Else
MsgBox "ErrSource: " & Err.Source & vbCrLf & "ErrNum: " & Err.Number & vbCrLf & "ErrDescription: " & vbCrLf & Err.Description
End Select
Resume zRecover
End Sub
Comment