Code below Blows up Outlook after 12 emails go out. Any way to add a delay after each email to keep that from happening. Maximum # of emails would be 40.
Got this code from a user in Microsoft Community last May. It works great until the number of emails exceeds 12 then I get 12 emails sent and email failure notifications from Outlook for the rest.Sub CreatePersonSpecificPDFs()
' -------------------------------
' Declarations
' -------------------------------
' This sub creates a .pdf file for individual timesheets for the event and "Blindly"
' emails them to the email address found on each timesheet
' Workbook object used 1. to loop through worksheets,
' 2. specify which worksheet to export as PDF.
Dim wsSource As Worksheet
Dim sEmailAddress As String
' File name and location.
Dim sPath As String
Dim sFileName As String
Dim sFileSpec As String
' Array holding "tab names" of person-specific worksheets.
Dim asSheetTabNames() As String
' Count of qualifying worksheets.
Dim iSheetsFound As Long
' Used for looping person-specific worksheets found.
Dim iSheet As Long
' Objects used for sending email via outlook.
Dim oOutlookApp As Object
Dim oMailItem As Object
Dim sMsg As String
' -------------------------------
' Initializations
' -------------------------------
sPath = ThisWorkbook.Path & "\"
iSheetsFound = 0
' -------------------------------
' ID Sheets to Export
' -------------------------------
' Iterate through the worksheets collection looking for person-
' specific worksheets to be exported as a PDF file.
' Load person-specific worksheet TAB names into the array.
For Each wsSource In ThisWorkbook.Worksheets
' Use worksheets' "code names" to determine which worksheets are to be exported.
' A person-specific worksheet has codename like Template# or like Template##
' where # is a wildcard indicating any numeric value.
If wsSource.CodeName Like "Template#" Or wsSource.CodeName Like "Template##" _
Then
iSheetsFound = iSheetsFound + 1
ReDim Preserve asSheetTabNames(iSheetsFound)
asSheetTabNames(iSheetsFound) = wsSource.Name
End If
Next wsSource
' -------------------------------------------------
' Check no Person-specific Sheets Found
' -------------------------------------------------
If iSheetsFound = 0 _
Then
sMsg = "No individual timesheets have been created"
MsgBox sMsg, vbCritical, "Create then email PDFs"
Exit Sub
End If
' ---------------------------------
' Export then Email PDFs
' ---------------------------------
For iSheet = 1 To iSheetsFound
sFileName = asSheetTabNames(iSheet) & ".PDF"
sFileSpec = sPath & sFileName
' Delete the file if it already exists.
On Error Resume Next
Kill sFileSpec
On Error GoTo 0
Set wsSource = ThisWorkbook.Worksheets(asSheetTabNames(iSheet))
wsSource.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=sFileSpec, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
' Get email address from the person-specific worksheet.
sEmailAddress = wsSource.Range("EmailAddress").Value
' Set up Outlook objects for sending email.
Set oOutlookApp = CreateObject("Outlook.Application")
Set oMailItem = oOutlookApp.CreateItem(0)
' Attach the single person-specific PDF file to an email.
With oMailItem
.To = "**Email removed for security* @aol.com)"
' .To = sEmailAddress 'Specify the email address of the recipient
.Subject = "Time Sheet"
.Body = "Please find attached your timesheet. Respond to this email with your acceptance."
.Attachments.Add sFileSpec
.Send
End With
Set oOutlookApp = Nothing
Set oMailItem = Nothing
Next iSheet
End Sub
