Public gcolEmails As Collection
Public Sub SendAllEmails()
Dim i As Integer
Dim vEmails, vFile, vCC
'MsgBox "Have Outlook open."
'SetWarnings False
vFile = ActiveWorkbook.FullName
collectEmailList 'gather all emails
vEmails = BuildBulkList()
Send1Email vEmails, "your data", "body of data", vCC, vFile
'SetWarnings True
MsgBox "Done"
Set gcolEmails = Nothing
End Sub
Private Sub collectEmailList()
Dim vTo, vWord, vName, vEmail, vReg, vCC
On Error GoTo errAdd
Set gcolEmails = New Collection
Sheets("EmailList").Activate 'goto the email list
'cycle thru the list of email addrs
Range("A2").Select
While ActiveCell.Value <> ""
vName = ActiveCell.Offset(0, 0).Value
vEmail = ActiveCell.Offset(0, 1).Value
gcolEmails.Add vEmail, vName 'add email to collection
ActiveCell.Offset(1, 0).Select 'next row
Wend
Exit Sub
errAdd:
If Err = 457 Then Resume Next 'prevent error for dupes
MsgBox Err.Description, , Err
End Sub
Private Function Send1Email(ByVal pvTo, ByVal pvSubj, ByVal pvBody, ByVal pvCC, Optional ByVal pvFile) As Boolean
Dim oMail As Outlook.MailItem
Dim oApp As Outlook.Application
On Error GoTo ErrMail
'NOTE : YOU MUST HAVE THE OUTLOOK X.x Object Library REFERENCE CHECKED IN VBE; ctl-G, menu,tools, references, Microsoft Outlook XX Object library
Set oApp = GetApplication("Outlook.Application") 'it may be open already so use this
'Set oApp = CreateObject("Outlook.Application") 'not this
Set oMail = oApp.CreateItem(olMailItem)
With oMail
.To = pvTo
.CC = pvCC
.Subject = pvSubj
If Not IsMissing(pvFile) Then .Attachments.Add pvFile, olByValue, 1
.HTMLBody = pvBody
.Display True
'.Send
End With
Send1Email = True
endit:
Set oMail = Nothing
Set oApp = Nothing
Exit Function
ErrMail:
MsgBox Err.Description, vbCritical, Err
Resume endit
Resume
End Function
Private Function GetApplication(className As String) As Object
' function to encapsulate the instantiation of an application object
Dim theApp As Object
On Error Resume Next
Set theApp = GetObject(, className)
If Err.Number <> 0 Then
MsgBox "Unable to Get" & className & ", attempting to CreateObject"
Set theApp = CreateObject(className)
End If
If theApp Is Nothing Then
Err.Raise Err.Number, Err.Source, "Unable to Get or Create the " & className & "!"
Set GetApplication = Nothing
End If
'MsgBox "Successfully got a handle on Outlook Application, returning to caller"
Set GetApplication = theApp
End Function
Private Function BuildBulkList()
Dim i As Integer
Dim vEList
For i = 1 To gcolEmails.Count
vEList = vEList & gcolEmails(i) & ";"
Next
BuildBulkList = vEList
'MsgBox vEList
End Function| Book6 | ||||||
|---|---|---|---|---|---|---|
| A | B | C | D | |||
| 1 | Name: | Shifts in Cashlfow To Cost Engineers Asking for Comments | ||||
| 2 | Subject: | Major LE Variance & Funding Exception Explanations - 2309 [CSPR] | ||||
| 3 | From: | Email1@Dummy.com | ||||
| 4 | To: | Email2@Dummy.com; Email3@dummy.com | ||||
| 5 | CC: | Email1@dummy.com | ||||
| 6 | Attachments: | 2309 Shifts in Cashflow in 5 Year Window and Funding Exceptions.xlsx | ||||
| 7 | Path: | Q:\Folder1\Sub Folder 2\Sub Folder 3\Cashflow and Funding Exception\ | ||||
| 8 | Body: (The <br> characters are for new lines in the Outlook html email. Adding hard returns in the cell has no affect other than to show the spaces here. <ul> sets bulleted section. <li> makes an indented bullet item.) | Hello cost engineers,<br><br> Please see the combined cash flow shift explanation requests & Funding Exceptions.<br><br> <u>For Major LE Variances (1st tab):</u><br> The Portfolio Support Team is compiling comments for all projects with LE variances from the previous baseline of greater than $250k. The focus is on shifts between years and changes in project LE. The 1st tab is a filtered list of projects that meet the mentioned criteria. It also highlights in yellow where variances occur.<br><br> <u>For Funding Exceptions (2nd tab):</u><br> We’re also compiling comments for all projects with [ACWP > Upper Range] and/or [Projects in Execute or Operate and Project EAC > Upper Range] . These are color coded as red & brown. No comments are needed for items in yellow or green.<br><br> Please return all comments back to me and your respective leads by October 11th , providing brief explanations explaining the variances.<br><br> Thank you<br> Jeff | ||||
| 9 | Date Formula 1: | October 11th | ||||
| 10 | Body 1: | Hello cost engineers,<br><br> Please see the combined cash flow shift explanation requests & Funding Exceptions.<br><br> <u>For Major LE Variances (1st tab):</u><br> The Portfolio Support Team is compiling comments for all projects with LE variances from the previous baseline of greater than $250k. The focus is on shifts between years and changes in project LE. The 1st tab is a filtered list of projects that meet the mentioned criteria. It also highlights in yellow where variances occur.<br><br> <u>For Funding Exceptions (2nd tab):</u><br> We’re also compiling comments for all projects with [ACWP > Upper Range] and/or [Projects in Execute or Operate and Project EAC > Upper Range] . These are color coded as red & brown. No comments are needed for items in yellow or green.<br><br> | ||||
| 11 | Body 2: | |||||
Sheet1 | ||||||
| Cell Formulas | ||
|---|---|---|
| Range | Formula | |
| D2 | D2 | ="Major LE Variance & Funding Exception Explanations - "&TEXT(EDATE(NOW(),-1),"YYMM")&" [CSPR]" |
| D6 | D6 | =TEXT(EDATE(NOW(),-1),"YYMM")&" Shifts in Cashflow in 5 Year Window and Funding Exceptions.xlsx" |
| D8 | D8 | =D10&" Please return all comments back to me and your respective leads by "&D9&" , providing brief explanations explaining the variances.<br><br> Thank you<br> Jeff" |
| D9 | D9 | =LET(Dt,XLOOKUP(TEXT(TODAY(),"YYYY-MM")&"_8",'Daily Manager_2.xlsm'!WDTbl[Combo],'Daily Manager_2.xlsm'!WDTbl[Workdays],0,0),TEXT(Dt,"MMMM")&" "&XLOOKUP(DAY(Dt),'Daily Manager_2.xlsm'!OrdinalTbl[Value],'Daily Manager_2.xlsm'!OrdinalTbl[Ordinal],0,0)) |
| Cells with Data Validation | ||
|---|---|---|
| Cell | Allow | Criteria |
| A3 | Any value | |
| A6 | Any value | |
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim i As Range
Dim R As Range
Dim Cel As Range
Dim EmailName As String
Dim HyperlinkStr As String
Dim Path As String
Dim FileName As String
Set R = Range("ChckLst_Tbl[Email]")
Set i = Intersect(R, Target)
If Not i Is Nothing Then
EmailName = i.Value
If EmailName <> "" Then
Cancel = True
Set R = EmailSht.Range("EmailNameRow")
For Each Cel In R
If Cel.Value = EmailName Then
EmailSubject = Cel.Offset(1, 0).Value
EmailFrom = Cel.Offset(2, 0).Value
EmailTo = Cel.Offset(3, 0).Value
EmailCC = Cel.Offset(4, 0).Value
EmailPath = Cel.Offset(6, 0).Value
EmailFileName = Cel.Offset(5, 0).Value
EmailBody = Cel.Offset(7, 0).Value
Call CreateEmail
Exit For
End If
Next Cel
End If
End If
End SubPublic EmailTo As String
Public EmailFrom As String
Public EmailCC As String
Public EmailSubject As String
Public EmailBody As String
Public EmailPath As String
Public EmailFileName As String
Sub CreateEmail()
Dim objOutlook As Object
Dim objMail As Object
Dim A As String
Dim Q As String
Dim OutAccnt As Outlook.account
Dim xOutMsg As String
Dim Hrt As String
Dim EmailFile(10) As String
Dim EmailFileCnt As Long
Dim X As Long
Dim Y As Long
Dim s1 As Long
Dim s2 As Long
Dim EmailPathFile As String
Dim PathFileError As String
Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)
If EmailFrom <> "" Then
Set OutAccnt = objOutlook.Session.Accounts.Item(EmailFrom)
End If
xOutMsg = "<font style=font-size:14pt;font-family:Calibri;color:#000000>"
xOutMsg = xOutMsg & EmailBody & vbNewLine & "</font>"
If EmailPath <> "" And Right(EmailPath, 1) <> "\" Then EmailPath = EmailPath & "\"
If EmailFileName <> "" Then
EmailFileCnt = Len(EmailFileName) - Len(Replace(EmailFileName, ";", "")) + 1
If EmailFileCnt = 1 Then
EmailFile(1) = EmailFileName
Else
For X = 1 To EmailFileCnt
s2 = InStr(s1 + 1, EmailFileName, ";")
If X = 1 Then
EmailFile(1) = Trim(Left(EmailFileName, s2 - 1))
s1 = s2
ElseIf X = EmailFileCnt Then
EmailFile(X) = Mid(EmailFileName, s1 + 1, 100)
ElseIf X > 1 And X < EmailFileCnt Then
EmailFile(X) = Trim(Mid(EmailFileName, s1 + 1, s2 - s1 - 1))
s1 = s2
End If
Next X
End If
End If
With objMail
.BodyFormat = olFormatHTML
.SendUsingAccount = OutAccnt 'Supposedly allows the correct Signature to be loaded
If EmailFrom <> "" Then
.SentOnBehalfOfName = EmailFrom 'OutAccnt 'Group email account
End If
.To = EmailTo
.CC = EmailCC
'.bcc = "Bla"
.Subject = EmailSubject
.Display 'Instead of .Display, you can use .Send to send the email
.HTMLBody = xOutMsg & .HTMLBody 'Put this after .Display to save the signature
'Error.Clear
On Error GoTo WeThePeople
For X = 1 To EmailFileCnt
EmailPathFile = EmailPath & EmailFile(X)
PathFileError = EmailPathFile
.Attachments.Add EmailPathFile, 1
Next X
'.Send or .Save to save a copy in the drafts folder
End With
Set objOutlook = Nothing
Set objMail = Nothing
Exit Sub
WeThePeople:
MsgBox "There was a problem attaching this file: " & vbNewLine & PathFileError
End Sub
