Hi Guys I'm kind of new to the macros and how to set it up.
I'm trying to run a automatic birthday macros that send an email out to people saying a happy birthday message.
but I'm struggling with when its Monday i want it to initiate a message for the weekend birthdays as well, but only on a Monday. My Code keeps saying "Run-time error '13': type mismatch". Here is my Code please help as I've been struggling a week with it
Sub send_bday_greet2()
Dim i As Long
Dim vbSunday As String, vbSaturday As String
For i = 2 To Sheets("Sheet1").Range("a1048576").End(xlUp).Row
If Day(Now()) = Day(CDate(Sheets("Sheet1").Range("c" & i).Value)) And Month(Now()) = Month(CDate(Sheets("Sheet1").Range("c" & i).Value)) Then
Call sending_bday_greetings_method2(Sheets("Sheet1").Range("a" & i).Value, Sheets("Sheet1").Range("b" & i).Value)
ElseIf Day(Now(vbMonday)) = Day(CDate(Sheets("Sheet1").Range("c" & i).Value)) And Month(Now(vbSaturday)) And Month(Now(vbSunday)) = Month(CDate(Sheets("Sheet1").Range("c" & i).Value)) Then
Call sending_bday_greetings_method2(Sheets("Sheet1").Range("a" & i).Value, Sheets("Sheet1").Range("b" & i).Value)
End If
Next
End Sub
Sub sending_bday_greetings_method2(nm As String, emid As String)
Dim olApp As Outlook.Application
Dim olMail As MailItem
Set olApp = New Outlook.Application
Set olMail = olApp.CreateItem(olMailItem)
s = "<p> <p align='left'><font size='3' face='arial' color='blue'><i> Dear " & nm & ", </p>" & vbNewLine
s = s & "<p> <p align='CENTER'><font size='3' face='arial' color='red'><i> We Wish you a very Happy Birthday! </p>" & vbNewLine
s = s & "<left><p align='CENTER'><img src=""http://simplyizzy.files.wordpress.com/2012/05/happy_birthday1.png"">" & vbNewLine
s = s & vbNewLine & "<left><p><p align='Left'><font size='3' face='arial' color='blue'><i>Regards<br>" & "Reutech Radar Systems</p>"
With olMail
.To = emid
.Subject = "Happy B'day!"
.HTMLBody = s
.Send
End With
Set olApp = Nothing
Set olMail = Nothing
End Sub
Your 1st issue is with Dim vbSunday As String, vbSaturday As String.
vbSaturday and vbSaturday are constants in VBA that are numbers, and you're trying to use them as String.
Furthermore, they are most probably protected so you won't be able to use their names as variable's name.
Your second issue is with Now(vbMonday) and others, you'll need to use a function like this to get the last day from the current date :
Public Function GetLastDay(ByVal DayAsVbConstant As Integer) As Date
GetLastDay = Now - (Weekday(Now, DayAsVbConstant) - 1)
End Function
Here is a revision of your code :
Sub send_bday_greet2()
Dim i As Long
Dim wS As Worksheet
Dim SendMessage As Boolean
Dim BirthDay As Date
'Set wS = ThisWorkbook.Sheets("Sheet1")
Set wS = ThisWorkbook.Sheets("Feuil1")
With wS
For i = 2 To .Range("A" & .Rows.Count).End(xlUp).Row
SendMessage = False
BirthDay = CDate(.Range("C" & i).Value)
Select Case True
Case Day(Now()) = Day(BirthDay) And Month(Now()) = Month(BirthDay)
'Birthday this day
SendMessage = True
Case Weekday(Now) = vbMonday And ( _
Day(GetLastDay(vbSaturday)) = Day(BirthDay) And _
Month(GetLastDay(vbSaturday)) = Month(BirthDay))
'Birthday on Saturday
SendMessage = True
Case Weekday(Now) = vbMonday And ( _
Day(GetLastDay(vbSunday)) = Day(BirthDay) And _
Month(GetLastDay(vbSunday)) = Month(BirthDay))
'Birthday on Sunday
SendMessage = True
Case Else
End Select
If SendMessage Then Call sending_bday_greetings_method2(.Range("a" & i).Value, .Range("b" & i).Value)
Next i
End With 'wS
End Sub
And the part to send the mail :
Sub sending_bday_greetings_method2(ByVal nm As String, ByVal emid As String)
Dim olApp As Outlook.Application
Dim olMail As MailItem
Set olApp = New Outlook.Application
Set olMail = olApp.CreateItem(olMailItem)
s = "<p> <p align='left'><font size='3' face='arial' color='blue'><i> Dear " & nm & ", </p>" & vbNewLine
s = s & "<p> <p align='CENTER'><font size='3' face='arial' color='red'><i> We Wish you a very Happy Birthday! </p>" & vbNewLine
s = s & "<left><p align='CENTER'><img src=""http://simplyizzy.files.wordpress.com/2012/05/happy_birthday1.png"">" & vbNewLine
s = s & vbNewLine & "<left><p><p align='Left'><font size='3' face='arial' color='blue'><i>Regards<br>" & "Reutech Radar Systems</p>"
With olMail
.To = emid
.Subject = "Happy B'day!"
.HTMLBody = s
.Display
'.Send
End With
Set olApp = Nothing
Set olMail = Nothing
End Sub
Related
I'm attempting to send an email for each attendance event that is being displayed within the Pivot Table. Though it will recognize the count of rows, only the 1st row is being sent in email up to as many emails as there are rows of data.
I believe I need my offset parameters to change so it's changing by row & cell. Any suggestions?
enter image description here
Sub EmailBody()
Application.ScreenUpdating = False
ThisWorkbook.RefreshAll
'Tells it to re-run every x hours and min.
Application.OnTime Now + TimeValue("1:00"), "EmailBody"
Dim sourceSheet As Worksheet
Set sourceSheet = ActiveSheet
Dim arrHolidays As Variant, iDay As Variant
arrHolidays = Application.Transpose(Worksheets("Hold").Range("a:a").Value) 'Add all your holidays on Holidays worksheet
For Each iDay In arrHolidays
If Date = iDay Then Exit Sub 'exit this sub if date is a holiday
Next
On Error Resume Next
ThisWorkbook.RefreshAll
Worksheets("Sheet1").Activate
'Creating references to Application and MailItem Objects of Outlook
Dim outApp As Outlook.Application
Dim outMail As Outlook.MailItem
'Creating variable to hold values of different items of mail
Dim sendTo, MailBody As String
Dim lstRow As Long
ThisWorkbook.Sheets("Sheet1").Activate
'Getting last row of containing email id.
lstRow = Cells(Rows.Count, 2).End(xlUp).Row
Dim rng As Range
Set rng = Range("B2:B" & lstRow)
'initializing outlook object to access its features
Set outApp = New Outlook.Application
On Error GoTo cleanup 'to handle any error during creation of object.
For Each i In Range("b2:b100")
MailBody = "Please see the following attendance event logged in SharePoint for " & i.Offset(0, -1) & "." & vbCr & vbCr & "Date of Absence " & " : " & i.Offset(0, 2) & vbCr & "Reason for Absence " & " : " & i.Offset(0, 3) & vbCr & "Ticket Entered on" & " : " & i.Offset(0, 4) & vbCr & "Created By" & " : " & i.Offset(0, 5) & vbCr & "Notes" & " : " & i.Offset(0, 6) & vbCr & vbCr & "Please reach out to DLWESTCCWALKERRETENTIONREPORTING#charter.com, if you have any questions."
For Each cell In rng
sendTo = Range(cell.Address).Offset(0, 0).Value2 & ";" & Range(cell.Address).Offset(0, 1).Value2
Subj = "Attendance Callout Event Notification"
Msg = MailBody
On Error Resume Next 'to hand any error during creation of below object
Set outMail = outApp.CreateItem(0)
'Writing and sending mail in new mail
With outMail
.To = sendTo
.Body = Msg
.Subject = Subj
.Display '
.Send
End With
On Error GoTo 0 'To clean any error captured earlier
Set outMail = Nothing 'nullifying outmail object for next mail
Next cell 'loop ends
cleanup: 'freeing all objects created
Set outApp = Nothing
Application.ScreenUpdating = True
Application.ScreenUpdating = True
Next
End Sub
I had originally posted a question about sending an email if a value in a cell changes, which was solved, but this post looks at storing the old value, so I created a new post as it is a new question.
My goal is to store the old value from a cell within a range of cells, and then based on a Name in another cell if the old value <> new value of the cell in that range an email is sent out stating the value has changed.
Below is the code I have set up based on other posts found in this forum and adjusted to suit my needs, of course it doesnt work, so I am asking for more guidance and assistance.
The first IF looks to see if the name was changed and if it was
sends out the email.
the second part looks at the name of the person in column C and if
information changes in a cell in column O it sends out another
email.
Code:
Dim laTargetVal
Dim clsDateTargetval
Private Sub Worksheet_Change(ByVal Target As Range)
Dim RgSel As Range, RgCell As Range
Dim lAmountCell As Range, lAmountSel As Range
Dim OutlookApp As Object, MItem As Object
Dim Subj As String, EmailAddr As String, Recipient As String
Dim CustName As String, TitleCo As String, ClsDate As String, ContractPrice As String, lAmount As String, Product As String, Msg As String, pEmail As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set RgCell = Range("C2:C100")
Set RgSel = Intersect(Target, RgCell)
Set lAmountCell = Range("O:O")
On Error Resume Next
If Not RgSel Is Nothing Then
Set OutlookApp = CreateObject("Outlook.Application")
For Each cell In RgSel
If cell.Value = "Zack" Then
If laTargetVal <> Target Then
Set MItem = OutlookApp.CreateItem(0)
pEmail = "[email address]"
CustName = cell.Offset(0, -1).Value
lAmount = Format(cell.Offset(0, 12).Value, "Currency")
ClsDate = cell.Offset(0, 5).Value
ContractPrice = Format(cell.Offset(0, 10).Value, "Currency")
Product = cell.Offset(0, 13).Value
TitleCo = cell.Offset(0, 1).Value
Subj = "***LOAN TERMS CHANGED***" & " - " & UCase(CustName)
Recipient = "Zack"
EmailAddr = pEmail
' Compose Message
Msg = "Hi " & Recipient & "," & vbCrLf & vbCrLf
Msg = Msg & "The following loan parameters have changed for " & CustName & vbCrLf & vbCrLf
Msg = Msg & " Product: " & Product & vbCrLf
Msg = Msg & " Loan Amount changed from: " & laTargetVal & " to " & lAmount & vbCrLf
Msg = Msg & " Closing Date: " & ClsDate & vbCrLf
Msg = Msg & " Title Company: " & TitleCo & vbCrLf
Msg = Msg & " Contract Price: " & ContractPrice & vbCrLf & vbCrLf
Msg = Msg & "Please review the information in their customer folder in the L: Drive." & vbCrLf & vbCrLf
Msg = Msg & "The Boss" & vbCrLf
Msg = Msg & "Vice President"
' Create Mail Item and send
With MItem
.To = EmailAddr
.Subject = Subj
.Body = Msg
.Send
End With
End If
End If
Next cell
End If
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim lAmountCell As Range, lAmountSel As Range
Dim clsDateCell As Range, clsDateSel As Range
Set lAmountCell = Range("O:O")
Set lAmountSel = Intersect(Target, lAmountCell)
Set clsDateCell = Range("H:H")
Set clsDateSel = Intersect(Target, clsDateCell)
If Not lAmountSel Is Nothing Then
laTargetVal = Format(Target, "Currency")
End If
If Not clsDateSel Is Nothing Then
clsDateTargetval = Target
End If
End Sub
So I built a code that works for mailing 1 list (in Column A): Cell A1 has a region, Cells A2 though last row have an email address that needs that email. This code works fine for column A. But if a made a list in Columns B-#( however many number of columns), could i add onto this code and make it create as many emails as there are columns, and send them to the list of people below row 2.
In other words, can we make this say for Each column with a value in the first row create and email and send it to everyone else below it?
thanks
Sub emailfromcolumns()
Dim olApp As Outlook.Application
Dim olMail As Outlook.MailItem
Dim MailMessage As String
Dim i As Long
Dim LastRow As Long
Dim Namelist As String
LastRow = Range("A" & rows.Count).End(xlUp).Row
'email recipients are in row 2 to the last row
For i = 2 To LastRow
If Sheets("Recipients").Range("A2").Value <> "" Then
Namelist = Namelist & ";" & Sheets("Recipients").Range("A" & i).Value
End If
Next
MailMessage = "<HTML><BODY> Good Afternoon All, <br><br>" _
& "<li>Please let me know if there is anything else you need or any changes you would like to see.<br><br>" _
& "<li>Thanks,<br><br>" _
& "Thank you, Pricing Team<br><br>" _
Set olApp = GetObject(Class:="Outlook.Application")
If olApp Is Nothing Then
Set olApp = CreateObject(Class:="outlook.application")
End If
Set olMail = olApp.CreateItem(0)
With olMail
.To = Namelist
.Subject = Range("A1").Value & " 60 Day Expiration " & Format(MonthName(Month(Now)))
.display
.HTMLBody = MailMessage
.Attachments.Add ("C:\Desktop\60 Day Exp\Savefiles\" & Range("A1").Value & " 60 Day Expirations " & Format(MonthName(Month(Now))) & ".xlsx")
.Save
.Close 1
End With
Set olMail = Nothing
Set olApp = Nothing
Application.ScreenUpdating = True
End Sub
I would make your existing routine accept a column number so you can pass any column to it, and then it will work for that column e.g.
Sub emailfromcolumns(COL As Long)
So then you can just call emailfromcolumns(1) to email for column A, emailfromcolumns(2) to email for column B etc.
Then you can create a second sub routine that finds out how many columns there are and just loops through them all, calling your existing routine:
Sub loopit()
Dim lastColumn As Long
Dim x As Long
lastColumn = Sheets("Recipients").Cells(1, Sheets("Recipients").Columns.Count).End(xlToLeft).Column
For x = 1 To lastColumn
emailfromcolumns (x)
Next x
End Sub
This means all you have to do to your existing code is replace any reference to column "A" with the variable COL - there are four lines:
change
LastRow = Range("A" & rows.Count).End(xlUp).Row
to
LastRow = Cells(Rows.Count, COL).End(xlUp).Row
change
If Sheets("Recipients").Range("A2").Value <> "" Then
Namelist = Namelist & ";" & Sheets("Recipients").Range("A" & i).Value
End If
to
If Cells(2, COL).Value2 <> "" Then
Namelist = Namelist & ";" & Cells(i, COL).Value2
End If
and the last two lines are within the e-mail bit:
.Subject = Sheets("Recipients").Cells(i, COL).Value2 & " 60 Day Expiration " & Format(MonthName(Month(Now)))
.Attachments.Add ("C:\Desktop\60 Day Exp\Savefiles\" & Sheets("Recipients").Cells(i, COL).Value2 & " 60 Day Expirations " & Format(MonthName(Month(Now))) & ".xlsx")
On top of this, your code has some risky sections where you're just referring to Range without declaring which sheet the range is on... below is full version tidied up with comments on the differences:
Sub emailfromcolumns(COL As Long)
Dim olApp As Outlook.Application
Dim olMail As Outlook.MailItem
Dim MailMessage As String
Dim i As Long
Dim LastRow As Long
Dim Namelist As String
Dim WS As Worksheet ' Declare a worksheet object
Set WS = ThisWorkbook.Worksheets("Recipients") ' set the worksheet object WS to "Recipients" for easy reference
LastRow = WS.Cells(WS.Rows.Count, COL).End(xlUp).Row ' last row now definitely referencing "Recipients" thanks to WS
'email recipients are in row 2 to the last row
' changed your "A2" check to outside the loop, don't need to check it each time
If WS.Cells(2, COL).Value2 <> "" Then
For i = 2 To LastRow
Namelist = Namelist & ";" & WS.Cells(i, COL).Value2
Next i
End If
MailMessage = "<HTML><BODY> Good Afternoon All, <br><br>" _
& "<li>Please let me know if there is anything else you need or any changes you would like to see.<br><br>" _
& "<li>Thanks,<br><br>" _
& "Thank you, Pricing Team<br><br>" _
Set olApp = GetObject(Class:="Outlook.Application")
If olApp Is Nothing Then Set olApp = CreateObject(Class:="outlook.application")
Set olMail = olApp.CreateItem(0)
With olMail
.To = Namelist
.Subject = WS.Cells(1, COL).Value2 & " 60 Day Expiration " & Format(MonthName(Month(Now)))
.display
.HTMLBody = MailMessage
.Attachments.Add ("C:\Desktop\60 Day Exp\Savefiles\" & WS.Cells(1, COL).Value2 & " 60 Day Expirations " & Format(MonthName(Month(Now))) & ".xlsx")
.Save
.Close 1
End With
Set olMail = Nothing
Set olApp = Nothing
Application.ScreenUpdating = True ' You didn't have anywhere that says Application.ScreenUpdating = False ?
End Sub
Sub emailfromcolumns()
Dim olApp As Outlook.Application
Dim olMail As Outlook.MailItem
Dim MailMessage As String
Dim i As Long
Dim z As Long
Dim LastRow As Long
Dim Namelist As String
Dim colCount As Long
'How Many Columns?
colCount = 4
'Loop through columns
For z = 1 To colCount
'email recipients are in row 2 to the last row
Namelist = vbNullString
With Worksheets("Recipients")
LastRow = .Cells(.Rows.Count, z).End(xlUp).Row
For i = 2 To LastRow
If .Cells(i, z).Value <> "" Then
Namelist = Namelist & ";" & .Cells(i, z).Value
End If
Next
End With
'Only create message if emails exist?
If Len(Namelist) > 0 Then
MailMessage = "<HTML><BODY> Good Afternoon All, <br><br>" _
& "<li>Please let me know if there is anything else you need or any changes you would like to see.<br> " _
& "<br>" _
& "<li>Thanks,<br><br>" _
& "Thank you, Pricing Team<br><br>" _
Set olApp = GetObject(Class:="Outlook.Application")
If olApp Is Nothing Then
Set olApp = CreateObject(Class:="outlook.application")
End If
Set olMail = olApp.CreateItem(0)
With olMail
.To = Namelist
.Subject = Sheets("Recipients").Cells(1, z).Value & " 60 Day Expiration " & Format(MonthName(Month(Now)))
.display
.HTMLBody = MailMessage
.Attachments.Add ("C:\Desktop\60 Day Exp\Savefiles\" & Sheets("Recipients").Cells(1, z).Value & " 60 Day Expirations " & Format(MonthName(Month(Now))) & ".xlsx")
.Save
.Close 1
End With
Set olMail = Nothing
Set olApp = Nothing
End If
Next z
Application.ScreenUpdating = True
End Sub
Emails I send through excel do not display the embedded images on the receivers end. However the embedded images do display on my end. My guess is that the path is associated with my desktop.
How can I get the images to be displayed? Having trouble figuring out a fix. My code is below:
Sub EmailDailyFlow()
Dim mainWB As Workbook
Set otlApp = CreateObject("Outlook.Application")
Set olMail = otlApp.CreateItem(olMailItem)
Set mainWB = ActiveWorkbook
With olMail
.To = "email#gmail.com"
.Cc = ""
.Subject = Format(Date - 1, "M.dd.yyyy") & " " & "MF & VIT Daily Fund Flow"
.HTMLBody = "<html><body style='font-family: Times New Roman, Times, serif; font-size: 16px;'>" & _
"<p>Please see below.</p>" & _
"<p><u><b>Volatility:</u></b></p>" & _
"<img src='C:\Users\Name\Desktop\MF-VIT Daily Fund Flow\images\MF.png'>" & _
"<p><u><b>Muni:</u></b></p>" & _
"<img src='C:\Users\Name\Desktop\MF-VIT Daily Fund Flow\images\MUNI.png'>" & _
"<p><u><b>AFC:</u></b></p>" & _
"<img src='C:\Users\Name\Desktop\MF-VIT Daily Fund Flow\images\AFC.png'>" & _
"<p><u><b>AFT:</u></b></p>" & _
"<img src='C:\Users\Name\Desktop\MF-VIT Daily Fund Flow\images\AFT.png'>" & _
"<p><u><b>VIT:</u></b></p>" & _
"<img src='C:\Users\Name\Desktop\MF-VIT Daily Fund Flow\images\VIT.png'>" & _
"<p>Thank you,</p>" & _
"</body></html>"
.Send
End With
MsgBox ("Daily flow emails sent!")
End Sub`
Try this code. Taken from some site long back, but still work like a charm.
Idea is to attach the image in hidden manner and later add it to using image name in the HtmlBody.
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Update:
I've added another function to retrieve image width and height. I've also updated existing sub to incorporate image size.
Sub EmailDailyFlow()
Dim SendID
Dim CCID
Dim Subject
Dim stdPic As StdPicture
Dim imageSize As String
Dim strPathImg1 As String
Dim strFileImg1 As String
Dim lngWidthImg1 As Long
Dim lngHeightImg1 As Long
Dim strPathImg2 As String
Dim strFileImg2 As String
Dim lngWidthImg2 As Long
Dim lngHeightImg2 As Long
Dim olMail As MailItem 'REQUIRES MICROSOFT OBJECT OUTLOOK LIBRARY REFERENCE
strPathImg1 = "C:\Users\Name\Desktop\MF-VIT Daily Fund Flow\images"
strFileImg1 = "MF.png"
imageSize = GetImageSize(strPathImg1, strFileImg1)
lngWidthImg1 = CLng(Split(imageSize, ":")(0))
lngHeightImg1 = CLng(Split(imageSize, ":")(1))
strPathImg2 = "C:\Users\Name\Desktop\MF-VIT Daily Fund Flow\images"
strFileImg2 = "MUNI.png"
imageSize = GetImageSize(strPathImg2, strFileImg2)
lngWidthImg2 = CLng(Split(imageSize, ":")(0))
lngHeightImg2 = CLng(Split(imageSize, ":")(1))
Set otlApp = CreateObject("Outlook.Application")
Set olMail = otlApp.CreateItem(olMailItem)
SendID = "email#gmail.com"
CCID = ""
Subject = Format(Date - 1, "M.dd.yyyy") & " " & "MF & VIT Daily Fund Flow"
With olMail
.To = SendID
If CCID <> "" Then
.CC = CCID
End If
.Subject = Subject
'ADD THE IMAGE IN HIDDEN MANNER, POSITION AT 0 WILL MAKE IT HIDDEN
.Attachments.Add strPathImg1 & "\" & strFileImg1, olByValue, 0
.Attachments.Add strPathImg2 & "\" & strFileImg2, olByValue, 0
'NOW ADD IT TO THE HTML BODY USING IMAGE NAME
'CHANGE THE SRC PROPERTY TO 'cid:your image filename'
'IT WILL BE CHANGED TO THE CORRECT CID WHEN ITS SENT.
.HTMLBody = "<html><body style='font-family: Times New Roman, Times, serif; font-size: 16px;'>" & _
"<p>Please see below.</p>" & _
"<p><u><b>Volatility:</u></b></p>" & _
"<img src='cid:" & strFileImg1 & "' width='" & lngWidthImg1 & "' height='" & lngHeightImg1 & "'>" & _
"<p><u><b>Muni:</u></b></p>" & _
"<img src='cid:" & strFileImg2 & "' width='" & lngWidthImg2 & "' height='" & lngHeightImg2 & "'>" & _
"<p><u><b>AFC:</u></b></p>" & _
"<p>Thank you,</p>" & _
"</body></html>"
'.Display 'UNCOMMENT ME IF YOU WANT TO DISPLAY THE EMAIL
.Send
End With
MsgBox ("Daily flow emails sent!")
End Sub
Function GetImageSize(filePath As String, fileName As String) As String
'THIS WILL RETURN IMAGE SIZE IN "xyz:xyz" STRING FORMAT
Dim strImageDimensions As String
Dim objShell As Object
Dim objFolder As Object
Dim objFile As Object
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.Namespace((filePath))
Set objFile = objFolder.ParseName(fileName)
strImageDimensions = objFile.ExtendedProperty("Dimensions")
strImageDimensions = Replace(Mid(strImageDimensions, 2, Len(strImageDimensions) - 2), " x ", ":")
GetImageSize = strImageDimensions
Set objFile = Nothing: Set objFolder = Nothing: Set objShell = Nothing
End Function
Sub EmailDailyFlow()
Dim oApp As Outlook.Application
Dim oEmail As MailItem
Dim colAttach As Outlook.Attachments
Dim oAttach1 As Outlook.Attachment
Dim oAttach2 As Outlook.Attachment
Dim oAttach3 As Outlook.Attachment
Dim oAttach4 As Outlook.Attachment
Dim oAttach5 As Outlook.Attachment
Dim olkPA As Outlook.PropertyAccessor
Const PR_ATTACH_CONTENT_ID="http://schemas.microsoft.com/mapi/proptag/0x3712001F"
Set oApp = CreateObject("Outlook.Application")
Set oEmail = oApp.CreateItem(olMailItem)
Set colAttach = oEmail.Attachments
Set oAttach1 = colAttach.Add("C:\Users\Name\Desktop\MF-VIT Daily Fund Flow\images\MF.png")
Set oAttach2 = colAttach.Add("C:\Users\Name\Desktop\MF-VIT Daily Fund Flow\images\Muni.png")
Set oAttach3 = colAttach.Add("C:\Users\Name\Desktop\MF-VIT Daily Fund Flow\images\AFC.png")
Set oAttach4 = colAttach.Add("C:\Users\Name\Desktop\MF-VIT Daily Fund Flow\images\AFT.png")
Set oAttach5 = colAttach.Add("C:\Users\Name\Desktop\MF-VIT Daily Fund Flow\images\VIT.png")
Set olkPA1 = oAttach1.PropertyAccessor
Set olkPA2 = oAttach2.PropertyAccessor
Set olkPA3 = oAttach3.PropertyAccessor
Set olkPA4 = oAttach4.PropertyAccessor
Set olkPA5 = oAttach5.PropertyAccessor
olkPA1.SetProperty PR_ATTACH_CONTENT_ID, "MF.png"
olkPA2.SetProperty PR_ATTACH_CONTENT_ID, "MUNI.png"
olkPA3.SetProperty PR_ATTACH_CONTENT_ID, "AFC.png"
olkPA4.SetProperty PR_ATTACH_CONTENT_ID, "AFT.png"
olkPA5.SetProperty PR_ATTACH_CONTENT_ID, "VIT.png"
oEmail.Close olSave
oEmail.HTMLBody = "<body style='font-family: Times New Roman, Times, serif; font-size: 16px;'><p>Please see below.</p>" & _
"<img src='cid:MF.png'>" & _
"<p><u><b>Muni:</u></b></p>" & _
"<img src='cid:MUNI.png'>" & _
"<p><u><b>afcCore:</u></b></p>" & _
"<img src='cid:AFC.png'>" & _
"<p><u><b>aft:</u></b></p>" & _
"<img src='cid:AFT.png'>" & _
"<p><u><b>VIT:</u></b></p>" & _
"<img src='cid:VIT.png'>" & _
"<p>Thank you,</p>" & _
"</body>"
oEmail.Save
oEmail.To = "email#email.com"
oEmail.CC = ""
oEmail.Subject = Format(Date - 1, "M.dd.yyyy") & " " & "MF & VIT Daily Fund Flow"
oEmail.Send
Set oEmail = Nothing
Set colAttach = Nothing
Set oAttach = Nothing
Set oApp = Nothing
End Sub
I am attempting to email to all email addresses in a table, with the subject line being the corresponding order number or numbers.
The Table has Five columns - "Line Number", "Order Number", "Suppler/Manf.Item Number", "Supplier Name" and "Email Address"
There can be duplicates, but the subject must contain each PO only once.
No CC, or BCC is required
The Body of the Email is to list the PO's with their associated line items.
Hello, We require an update as to the following:
EX
PO86001763
Line Item 2
Line Item 1
Please Send an update as to the status of these line items.
Providing the following: Packing Slips, Tracking Numbers and Updated Ship Dates.
(These being able to be edited would be a boon)
The table is made from an import and format macro, it will always be in the same format, but will contain different data. The amount of data can increase or decrease depending on the week.
Here is my attempt.
Private Sub CommandButton2_Click()
Dim subjectLine As String
Dim bodyline As String
Dim tb As ListObject
Dim lineCounter As Long
Dim myArray1, arrayCounter As Long, tempNumb As Long
Dim nameCounter As Long
Dim emAddress As String
ReDim myArray1(1 To 1)
arrayCounter = 0
nameCounter = 1
Dim I As Integer
Dim X As Integer
Dim C As Object
Dim firstaddress As Variant
Dim Nrow As Boolean
Set tb = ActiveSheet.ListObjects("Table10")
For I = 1 To ActiveSheet.ListObjects("Table10").ListRows.Count
emAddress = tb.DataBodyRange.Cells(I, tb.ListColumns("Email Address").Index)
For X = LBound(myArray1) To UBound(myArray1)
On Error Resume Next
If emAddress = myArray1(X) Then GoTo goToNext
Next X
On Error GoTo 0
subjectLine = "Order(s) # "
ReDim Preserve myArray1(1 To nameCounter)
myArray1(nameCounter) = emAddress
nameCounter = nameCounter + 1
lineCounter = 1
With tb.ListColumns("Email Address").Range
Set C = .Find(emAddress, LookIn:=xlValues)
If Not C Is Nothing Then
firstaddress = C.Address
Beep
arrayCounter = arrayCounter + 1
Do
Nrow = C.Row - 1
If lineCounter = 1 Then
subjectLine = subjectLine & tb.DataBodyRange.Cells (Nrow, tb.ListColumns("Order Number").Index)
lineCounter = lineCounter + 1
bodyline = "Order " & tb.DataBodyRange.Cells(Nrow, tb.ListColumns("Order Number").Index) & ", Line Number " & tb.DataBodyRange.Cells(Nrow, tb.ListColumns("Line Number").Index)
Else:
subjectLine = subjectLine & ", " & tb.DataBodyRange.Cells(Nrow, tb.ListColumns("Order Number").Index)
bodyline = bodyline & vbNewLine & "Order " & tb.DataBodyRange.Cells(Nrow, tb.ListColumns("Order Number").Index) & ", Line Number " & tb.DataBodyRange.Cells(Nrow, tb.ListColumns("Line Number").Index)
End If
Set C = .FindNext(C)
Loop While Not C Is Nothing And C.Address <> firstaddress
End If
Run SendMailFunction(emAddress, subjectLine, bodyline)
' Debug.Print vbNewLine
' Debug.Print emAddress
' Debug.Print "Subject: " & subjectLine
' Debug.Print "Body:" & vbNewLine; bodyline
End With
goToNext:
Next I
Set C = Nothing
End Sub
Function SendMailFunction(emAddress As String, subjectLine As String, bodyline As String)
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Dim tb As ListObject
Dim NL As String
Dim DNL As String
Dim I As Integer
NL = vbNewLine
DNL = vbNewLine & vbNewLine
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
Set tb = ActiveSheet.ListObjects("Table10")
For I = 1 To ActiveSheet.ListObjects("Table10").ListRows.Count
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = emAddress
.Subject = subjectLine
.Body = "Hello, We require an update as to the following:" & DNL & bodyline _
& DNL & _
"Please Send an update as to the status of these line items " & _
"providing the following: Packing Slips, Tracking Numbers and Updated Ship Dates."
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
Next I
End Function
The following code uses the email script as a function, which is called from the top macro. Please click on answer if this solves your problem
Sub findMethodINtable()
Dim subjectLine As String
Dim bodyline As String
Dim tb As ListObject
Dim lineCounter As Long
Dim myArray1, arrayCounter As Long, tempNumb As Long
Dim nameCounter As Long
Dim emAddress As String
ReDim myArray1(1 To 1)
arrayCounter = 0
nameCounter = 1
Set tb = ActiveSheet.ListObjects("Table14")
For i = 1 To ActiveSheet.ListObjects("Table14").ListRows.Count
emAddress = tb.DataBodyRange.Cells(i, tb.ListColumns("Email Address").Index)
For x = LBound(myArray1) To UBound(myArray1)
On Error Resume Next
If emAddress = myArray1(x) Then GoTo goToNext
Next x
On Error GoTo 0
subjectLine = "Order(s) # "
ReDim Preserve myArray1(1 To nameCounter)
myArray1(nameCounter) = emAddress
nameCounter = nameCounter + 1
lineCounter = 1
With tb.ListColumns("Email Address").Range
Set c = .Find(emAddress, LookIn:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
Beep
arrayCounter = arrayCounter + 1
Do
nRow = c.Row - 1
If lineCounter = 1 Then
subjectLine = subjectLine & tb.DataBodyRange.Cells(nRow, tb.ListColumns("Order Number").Index)
lineCounter = lineCounter + 1
bodyline = "Order " & tb.DataBodyRange.Cells(nRow, tb.ListColumns("Order Number").Index) & ", Line Number " & tb.DataBodyRange.Cells(nRow, tb.ListColumns("Line Number").Index)
Else:
subjectLine = subjectLine & ", " & tb.DataBodyRange.Cells(nRow, tb.ListColumns("Order Number").Index)
bodyline = bodyline & vbNewLine & "Order " & tb.DataBodyRange.Cells(nRow, tb.ListColumns("Order Number").Index) & ", Line Number " & tb.DataBodyRange.Cells(nRow, tb.ListColumns("Line Number").Index)
End If
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
Run SendMailFunction(emAddress, subjectLine, bodyline)
' Debug.Print vbNewLine
' Debug.Print emAddress
' Debug.Print "Subject: " & subjectLine
' Debug.Print "Body:" & vbNewLine; bodyline
End With
goToNext:
Next i
Set c = Nothing
End Sub
Function SendMailFunction(emAddress As String, subjectLine As String, bodyline As String)
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Dim tb As ListObject
Dim NL As String
Dim DNL As String
NL = vbNewLine
DNL = vbNewLine & vbNewLine
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
Set tb = ActiveSheet.ListObjects("Table14")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = emAddress
.Subject = subjectLine
.Body = "Hello, We require an update as to the following:" & DNL & bodyline _
& DNL & _
"Please Send an update as to the status of these line items " & _
"providing the following: Packing Slips, Tracking Numbers and Updated Ship Dates."
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
End Function
This works for me, given table name is "Table14"
Sub wserlkug()
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Dim tb As ListObject
Dim NL As String
Dim DNL As String
NL = vbNewLine
DNL = vbNewLine & vbNewLine
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
Set tb = ActiveSheet.ListObjects("Table14")
For i = 1 To ActiveSheet.ListObjects("Table14").ListRows.Count
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = ActiveSheet.ListObjects("Table14").DataBodyRange.Cells(i, tb.ListColumns("Email Address").Index)
.Subject = "Order # " & ActiveSheet.ListObjects("Table14").DataBodyRange.Cells(i, tb.ListColumns("Order Number").Index)
.Body = "Hello, We require an update as to the following:" & DNL & "Line #: " & ActiveSheet.ListObjects("Table14").DataBodyRange.Cells(i, tb.ListColumns("Line Number").Index) _
& DNL & _
"Please Send an update as to the status of these line items " & _
"providing the following: Packing Slips, Tracking Numbers and Updated Ship Dates."
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
Next i
End Sub
You can actually use the object variable "tb" instead of ActiveSheet.ListObjects("Table14").... I placed that there to show how to reference row and column in a table.