Hi snb thanks for your quick reply.
Code below. It's a sub from a userForm - can post the entire frx if you want.
There are a few global variables/data types used that are not declared in the snippet but it should all be fairly clear.
Private Sub btnGo_Click()
Dim objOutlook As Outlook.Application
Dim objEmail As Outlook.MailItem
Dim shtDL As Worksheet 'distribution list
Dim rCur As Long 'current row number
Dim rMax As Long 'last row number of dist list
Dim pwCur As Integer 'current progress bar width
Dim pwPrv As Integer 'progress bar width at last update
Dim validationResult As validationReport
Dim attPath As String 'path for individual attachment files
'reset progress bar
lblComplete.Visible = False
lblProgress.Width = 0
'warn if sending live emails
If Not chkDraft Then
If MsgBox("If Outlook is currently online then this will instantly send emails to everyone in the selected distribution list. Continue?", _
vbOKCancel + vbExclamation + vbDefaultButton2, "Emailer") = vbCancel Then Exit Sub
End If
'set reference to user's chosen distribution list
Set shtDL = ThisWorkbook.Sheets(cbxDistList.Value)
'detect last data row in shtDL
rMax = shtDL.Cells(65536, 1).End(xlUp).Row
'validate shtDL
validationResult = listValidate(shtDL, rMax)
If validationResult.badRowCount > 0 Then
With shtDL
.Activate
.Cells(rMax, 1).Select
.Cells(validationResult.firstBadRow, 1).Select
End With
If MsgBox(validationResult.badRowCount & " invalid row" & IIf(validationResult.badRowCount = 1, "", "s") & _
" found in distribution list. Proceed anyway and skip " & IIf(validationResult.badRowCount = 1, "it?", "them?"), _
vbOKCancel + vbExclamation + vbDefaultButton2, "Emailer") = vbCancel Then Exit Sub
End If
'read HTML body text
On Error Resume Next
Set hb = fs.openTextFile(pthH & cbxHTMLsrc)
HTMLbody = hb.ReadAll
hb.Close
Set hb = Nothing
If Err.Number Then MsgBox "Error opening " & cbxHTMLsrc & vbCrLf & Err.Description, vbCritical, "Emailer": GoTo localErr
'generate emails
On Error GoTo 0
Set objOutlook = CreateObject("Outlook.Application")
objOutlook.Session.Logon
If optEmlIndivs Then 'user specified send as individual emails
'initialise progress bar
pwPrv = -1
pwCur = 0
lblProgress.Visible = True
'loop through distribution list
For rCur = 2 To rMax
'update progress bar
pwCur = Int((rCur / rMax) * pwMax)
If pwCur > pwPrv + 10 Then 'increment in large steps to prevent userform flickering
pwPrv = pwCur
lblProgress.Width = pwCur
Me.Repaint
End If
'create email; ignore rows explicity marked as to be skipped or invalid (listValidate filled them with orange)
If LCase(shtDL.Cells(rCur, 3)) <> "yes" And shtDL.Rows(rCur).Interior.ColorIndex = xlNone Then
'create email object
Set objEmail = objOutlook.CreateItem(0)
'add any specified attachments
addAttachments objEmail
With objEmail
.To = shtDL.Cells(rCur, 1)
.Subject = Replace(txtSubject, "[NAME]", shtDL.Cells(rCur, 2))
.HTMLbody = Replace(HTMLbody, "[NAME]", shtDL.Cells(rCur, 2))
If chkDraft Then
.Save
.Close False
Else
.Send
End If
End With
End If
Next rCur
Else 'send as group email
'write me
End If
objOutlook.Session.Logoff
Set objOutlook = Nothing
lblProgress.Width = pwMax
lblComplete.Caption = """" & cbxDistList & """ processed successfully"
lblComplete.Visible = True
localErr:
Err.Clear
End Sub
Bookmarks