Trouble adding multiple images to an e-mail - excel

I have an e-mail that is generated through Excel with VBA. This e-mail includes two embedded pictures in the body of the e-mail along with the separate hyperlinks to the videos they refer to. The problem is that it isn't recognizing the second picture and just embedding the same picture twice, however the hyperlinks are correct. Below is a sample of my code:
Private Sub SubmitBtn_Click()
Dim Source As Range
Dim Dest As Workbook
Dim wb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim OutApp As Object
Dim OutMail As Object
Dim MemNme As String, Email As String, UsrName As String, domainID As String, pic As String, pic2 As String
Dim Hlink As String, Hlink2 As String
State = Screener.StateBox
If State = "California" Then
If Screener.MktPlcBox = True Then
pic = "websitewithpicture1"
Hlink = "videolink"
count = 1
End If
If Screener.SubsidyBox = True Then
pic2 = "websitewithpicture2"
Hlink2 = "videolink"
count = 2
End If
With OutMail
.To = Email
.CC = ""
.BCC = ""
.Subject = "Helpful Video"
.HTMLBody = "Dear " & MemNme & ",<br><br>" _
& vbNewLine & vbNewLine & "Thank you for speaking with me today about your plan. You have a lot of choices, " _
& " and <b>we appreciate you choosing company</b>. Helping you understand your plan is important to us and I thought this video would be valuable to you.<br><br>" _
& vbNewLine & "<center><a href=" & Hlink & "<img src=cid:" & Replace(pic, " ", " ", "520") & " height =250 width=400></a>" _
& "<a href=" & Hlink2 & "<img src=cid:" & Replace(pic2, " ", " ", "420") & " height =250 width=400></a></center><br>" _
& vbNewLine & vbNewLine & "You can always get additional information at <b>website.com</b> or by calling the number on the back of your card.<br><br>" _
& vbNewLine & vbNewLine & "Thank you,<br>" _
& vbNewLine & UsrName
.Attachments.Add pic, olByValue, 0
.Attachments.Add pic2, olByValue, 0 <--------It doesn't "See" this pic???
' MsgBox "Press ok to create your e-mail"
.Display 'or use .Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
Unload Me
End Sub

Related

How to have Send To comprise of emails from worksheets that were proven true

I am trying to get my email lists from all worksheets that apply to the set rules to pull the email lists from said worksheet when appropriate. The column for mailing is S for every worksheet. I'm new to vba so I'm struggling a bit. This is the code I currently have. I guess I want the rules to kind of apply to the email list as well and pull from pages that have been proven true to generate the email in the first place. Thank you in advance for any help.
Option Explicit
Sub Main_AllWorksheets()
Dim sh As Worksheet, i As Long, shtsRotations As String
Dim shtsFunctions As String, shtsOK As String
Dim shtsManufacture As String
For Each sh In ActiveWorkbook.Worksheets
If Application.CountIf(sh.Range("O3:O70"), "<1") > 0 Then
shtsRotations = shtsRotations & vbLf & sh.Name
Else
shtsOK = shtsOK & vbLf & sh.Name & " (Rotations)"
End If
If Application.CountIf(sh.Range("P3:P70"), "<1") > 0 Then
shtsFunctions = shtsFunctions & vbLf & sh.Name
Else
shtsOK = shtsOK & vbLf & sh.Name & " (Functions)"
End If
If Application.CountIf(sh.Range("Q3:Q70"), "<1") > 0 Then
shtsManufacture = shtsManufacture & vbLf & sh.Name
Else
shtsOK = shtsOK & vbLf & sh.Name & " (Manufacturing Date)"
End If
Next sh
Dim myDataRng As Range
Set myDataRng = Range("S2:S15" & Cells(Rows.Count, "S").End(xlUp).Row)
Dim cell As Range
Dim iCnt As Integer
Dim sMail_ids As String
For Each cell In myDataRng
If Trim(sMail_ids) = "" Then
sMail_ids = cell.Offset(1, 0).Value
Else
sMail_ids = sMail_ids & vbCrLf & ";" & cell.Offset(1, 0).Value
End If
Next cell
Set myDataRng = Nothing ' Clear the range.
If Len(shtsRotations) > 0 Then
SendReminderMail sMail_ids, "Equipment rotations are due!", _
"Hello Team, " & vbNewLine & vbNewLine & _
"Check customer sheets: " & shtsRotations & vbLf & vbNewLine & _
"In the attatched workbook, you can see what equipment needs to be rotated by the red dates, indicating their last rotation."
End If
If Len(shtsFunctions) > 0 Then
SendReminderMail "sMail_ids", "Equipment functions are due! ", _
"Hello Team, " & vbNewLine & vbNewLine & _
"Check customer sheets: " & shtsFunctions & vbLf & vbNewLine & _
"In the attatched workbook, you can see what equipment needs to be functioned by the red dates, indicating their last function."
End If
If Len(shtsManufacture) > 0 Then
SendReminderMail "test#test.com", "Manufacturing date has surpassed 3 years!", _
"Hello Team, " & vbNewLine & vbNewLine & _
"Check customer sheets: " & shtsRotations & vbLf & vbNewLine & _
"In the attatched workbook, you can see what equipment has reached it's 3 years past manufacturing."
End If
If Len(shtsOK) > 0 Then
MsgBox "These sheets are OK: " & vbLf & shtsOK, vbInformation
End If
End Sub
Sub SendReminderMail(sTo As String, sSubject As String, sBody As String)
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim FileExtStr As String
Dim OutApp As Object
Dim OutMail As Object
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set wb1 = ActiveWorkbook
TempFilePath = Environ$("temp") & "\"
TempFileName = "Copy of " & wb1.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")
FileExtStr = "." & LCase(Right(wb1.Name, Len(wb1.Name) - InStrRev(wb1.Name, ".", , 1)))
wb1.SaveCopyAs TempFilePath & TempFileName & FileExtStr
Set wb2 = Workbooks.Open(TempFilePath & TempFileName & FileExtStr)
wb2.Worksheets(1).Range("A1").Value = "Copy created on " & Format(Date, "dd-mmm-yyyy")
wb2.Save
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.to = sTo
.CC = ""
.BCC = ""
.Subject = sSubject
.Body = sBody
.Attachments.Add wb2.FullName
.Display 'or use .Display
End With
On Error GoTo 0
wb2.Close savechanges:=False
Kill TempFilePath & TempFileName & FileExtStr
Set OutMail = Nothing
Set OutApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
MsgBox "Your Automated Email for the Workbook was successfully ran at " & TimeValue(Now), vbInformation
End Sub
Use the Recipients property of the MailItem class for specifying recipients. For example:
recipients = mail.Recipients
' now we add new recipietns to the e-mail
recipientTo = recipients.Add("Eugene Astafiev")
recipientTo.Type = Outlook.OlMailRecipientType.olTo
recipientCC = recipients.Add("Dmitry K.")
recipientCC.Type = Outlook.OlMailRecipientType.olCC
recipientBCC = recipients.Add("eugene.astafiev#somedomain.com")
recipientBCC.Type = Outlook.OlMailRecipientType.olBCC
retValue = recipients.ResolveAll()
Read more about that in the following articles:
How To: Fill TO,CC and BCC fields in Outlook programmatically
How To: Create and send an Outlook message programmatically

How do I attach specific sheets as a csv to an email?

I'm trying to attach three sheets to an email to be sent to a certain email address with a certain subject and content.
I currently attach each sheet in the workbook to an email each.
The two problems I'm looking to solve -
It currently cycles through all sheets, I want to attach sheets labeled "Account", "Subscription", "Users" so I can have another sheet for instructions.
Can I get attach all three to a single email? My research so far has come up blank.
I tried using something like the below, but that created errors in other areas that I don't know.
For Each ws In Sheets(Array("Account", "Subscription", "Users"))
Sub COMEON()
Dim onePublishObject As PublishObject
Dim oneSheet As Worksheet
Dim scriptingObject As Object
Dim outlookApplication As Object
Dim outlookMail As Object
Dim htmlBody As String
Dim htmlFile As String
Dim textStream, fil As String
Dim dummy As Workbook
Dim var As String
var = Range("A1").Value
Today = Format(Now(), "dd-mm-yyyy")
Set dummy = ActiveWorkbook
Set scriptingObject = CreateObject("Scripting.FileSystemObject")
Set outlookApplication = CreateObject("Outlook.Application")
For Each oneSheet In ActiveWorkbook.Worksheets
Dim StrBody As String
StrBody = " THIS IS A TEST" & " " & UCase(oneSheet.Name) & " " & "XYZ," & vbNewLine & _
vbNewLine & _
"Please FIND ATTACHED <B>'XYZ REPORT'<B>"
Application.DisplayAlerts = False
Sheets(oneSheet.Name).Copy
ActiveWorkbook.SaveAs dummy.Path & "\" & oneSheet.Name & ".csv"
ActiveWorkbook.Close
Application.DisplayAlerts = True
Set outlookMail = outlookApplication.CreateItem(0)
With outlookMail
.To = "XXXXX#XXXXX.com"
.htmlBody = StrBody & htmlBody
.attachments.Add dummy.Path & "\" & oneSheet.Name & ".csv"
.Display
.Subject = var & " - " & UCase(oneSheet.Name) & " CSV " & "(" & Today & ")"
End With
Next oneSheet
End Sub
Should be close:
Sub COMEON()
Dim oneSheet As Worksheet
Dim scriptingObject As Object
Dim outlookApplication As Object
Dim outlookMail As Object
Dim htmlBody As String
Dim dummy As Workbook
Dim var As String
Dim StrBody As String, arrSheets, Today
var = Range("A1").Value
Today = Format(Now(), "dd-mm-yyyy")
Set dummy = ActiveWorkbook
Set outlookApplication = CreateObject("Outlook.Application")
Set outlookMail = outlookApplication.CreateItem(0)
With outlookMail
.To = "XXXXX#XXXXX.com"
.bodyformat = 1 'HTML
.Subject = var & " - CSV " & "(" & Today & ")"
.Display
End With
StrBody = "THIS IS A TEST<br><br>Files: <ul>"
arrSheets = Array("Account", "Subscription", "Users")
For Each oneSheet In dummy.Worksheets
If Not IsError(Application.Match(oneSheet.Name, arrSheets, 0)) Then
StrBody = StrBody & "<li>" & oneSheet.Name & "</li>"
Application.DisplayAlerts = False
Sheets(oneSheet.Name).Copy
ActiveWorkbook.SaveAs dummy.Path & "\" & oneSheet.Name & ".csv"
ActiveWorkbook.Close
Application.DisplayAlerts = True
'add attachment
outlookMail.attachments.Add dummy.Path & "\" & oneSheet.Name & ".csv"
End If 'want this sheet
Next oneSheet
With outlookMail
.htmlBody = StrBody & "</ul>" & .htmlBody
End With
End Sub
Basically move stuff out of the loop that doesn't need to be there.

Excel VBA: The leading zero is missing when use as email address

I am trying to draft a new email with Excel VBA and add the email address "00000#mycompany.com" in the cc list, while "00000" is the 5 digits staff number. The user should fill in their staff number in the form range "T5", "V5", or "X5".
However, if their staff number starts with zero, the leading zero will be missing in the email address.
For example, the number they filled is "01234", but the email address in the draft email will be "1234#mycompany.com"
I have tried
.text
.numberformat="#" and
.numberformat="00000"
but they are not working.
Could anyone help me with this? thanks a lot!
Private Sub sendmail_Click()
Dim sh As Worksheet
Set sh = ThisWorkbook.Sheets("Form")
Dim OA As Object
Dim msg As Object
Dim filepath As String
Set OA = CreateObject("Outlook.Application")
Dim folder
Set folder = CreateObject("scripting.filesystemobject")
Set msg = OA.CreateItem(0)
With msg
.display
End With
signature = msg.Body
Dim var_cc As String
var_cc = ""
With msg
.To = "abc#mycompany.com"
If Application.WorksheetFunction.IsNumber(sh.Range("T5")) = True Then
var_cc = var_cc & sh.Range("T5").NumberFormat = "#" & "#mycompany.com;"
Else
End If
If Application.WorksheetFunction.IsNumber(sh.Range("V5")) = True Then
var_cc = var_cc & sh.Range("V5").Value & "#mycompany.com;;"
Else
End If
If Application.WorksheetFunction.IsNumber(sh.Range("X5")) = True Then
var_cc = var_cc & sh.Range("X5").Value & "#mycompany.com;;"
Else
End If
.cc = var_cc
.Subject = sh.Range("G5").Value & " " & sh.Range("D5").Value & " " & sh.Range("A5").Value & " " & sh.Range("E3").Value & " / " &
sh.Range("E2").Value
.Body = "Dear All," & vbNewLine & _
"Please find attached missing info. Thank you." & _
vbNewLine & signature
.importance = 2
.Attachments.Add (Application.ActiveWorkbook.FullName)
End With
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
You may use
var_cc = var_cc & Format(sh.Range("T5").Value, "00000") & "#mycompany.com;"
instead of
var_cc = var_cc & sh.Range("T5").NumberFormat = "#" & "#mycompany.com;"

Adding attachment to email

I want to create a button that saves a worksheet in pdf format, Attaches to a new mail and send it.
i can create the pdf, save the pdf on my desktop, create and e-mail. but the PDF is never attached. Where am I going wrong?
Dim pdfName As String
pdfName = PONumberLabel.Caption ' add PO number on label to a variable
' create pdf and save to desktop
ChDir "C:\Users\roanderson\Desktop" ' selects directory to save
Sheet4.ExportAsFixedFormat _
Type:=xlTypePDF, _
OpenAfterPublish:=True, _
Quality:=xlQualityStandard, _
Filename:="C:\Users\roanderson\Desktop\" & pdfName ' directory put t
' sending email for approval
Dim xOutApp As Object
Dim xOutMail As Object
Dim xMailBody As String
On Error Resume Next
Set xOutApp = CreateObject("Outlook.Application")
Set xOutMail = xOutApp.CreateItem(0)
xMailBody = "Please approve PO Number" & " " & PONumber & vbNewLine & vbNewLine & _
"Cost Centre:" & " " & costcentre & vbNewLine & _
"Description:" & " " & description & vbNewLine & _
"Currency:" & " " & POCurrency & vbNewLine & _
" Total:" & " " & total
On Error Resume Next
With xOutMail
.To = "Ross.anderson#work.com"
.CC = ""
.BCC = ""
.Subject = "PO Number " & PONumber & " " & "Approval"
.Body = xMailBody
.Display 'or use .Send
.Attachments.Add "C:\Users\roanderson\Desktop\" & pdfName
.VotingOptions = "Accept;Reject"
End With
On Error GoTo 0
Set xOutMail = Nothing
Set xOutApp = Nothing
Everything works except attaching pdf to email.
Change the Statement
.Attachments.Add "C:\Users\roanderson\Desktop\" & pdfName
To
.Attachments.Add "C:\Users\roanderson\Desktop\" & pdfName & ".pdf"
As it seems like pdfname does not have the full name with Extension.

VBA File Directory Link into Outlook

I have the following code written (based on other posts here in SO) to insert a hyperlink to the folder that the workbook is saved in on a network drive into the body of an Email and the link does not show up in the body of the Email and I am at a loss as to why. Any help is greatly appreciated.
I do have the Microsoft Outlook Object Library checked in the References.
I have tried hyperlink = "" and hyperlink = "" to no avail.
Below is the full code:
Private Sub FileToApprRev_Click()
Dim OutlookApp As Object, MItem As Object
Dim Subj As String, EmailAddr As String, Recipient As String
Dim LienPos As Range, clsDate As Range, address As String, lNum As Range, Street As Range, City As Range, State As Range, ZipCode As Range, CustName As Range
Dim strBody As String, Email As String, hyperlink As String, currDir As String
Set wb = Application.ThisWorkbook
Set wsSI = wb.Sheets("SavedInfo")
Set Street = wsSI.Range("Street")
Set City = wsSI.Range("City")
Set State = wsSI.Range("State")
Set ZipCode = wsSI.Range("Zip")
Set lNum = wsSI.Range("Loan_Number")
Set clsDate = wsSI.Range("Closing_Date")
Set LienPos = wsSI.Range("Lien_Position")
Set CustName = wsSI.Range("PBName")
address = Street & ", " & City & ", " & State & " " & ZipCode
Set OutlookApp = CreateObject("Outlook.Application")
Set MItem = OutlookApp.CreateItem(0)
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Email = "SpongeBob#UnderTheSeaHeaven.com"
currDir = wb.path
hyperlink = ""
Debug.Print hyperlink
strBody = "<p>" & "Hello , " & "<br><br>" & vbNewLine & vbNewLine & _
"Please complete the Appraisal Review for the file below." & "</p>" & vbNewLine & _
hyperlink
With MItem
.Display
.to = Email
.Subject = "ATTN - Appraisal Review" & " - " & CustName & " - " & clsDate
.HTMLBody = strBody & "<br>" & .HTMLBody
.send
End With
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
I figured it out. I was using the incorrect structure for the file directory.
target = "\\fsps02\users\......"

Resources