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;"
Related
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.
I'm trying to send an email with the body of the message consisting of the contents of a text box. So far I've tried pulling in the text box through vba as a string, but that takes away all the new-lines formatting. Is there a way to get the text box contents exactly as they are into the email?
Sub Send_Email()
Dim OutApp As Object
Dim OutMail As Object
Dim title As String, emailto As String
Dim texts As String
title = Range("email_subject").Value
emailto = Range("email_to").Value
texts = Worksheets("Input").Shapes("TextBox 2").TextFrame.Characters.Text
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = emailto
.Subject = title
.HTMLBody = texts
.display
End With
On Error GoTo 0
End Sub
Please find an example below that might help with your question. You will have global variable that will hold information from excel worksheet and use them in the email. Whithout a image on how your data looks cannot really guess what you are trying to do. Maybe you can separete the text in different cells that way you can loop throught and put them in different variables and you can construct your email in the SendEmail procedure. Or if you have the same text and it doesn't change you can make it as per the below example.
Option Explicit
Dim titleName As String
Dim firstName As String
Dim lastName As String
Dim fullName As String
Dim clientEmail As String
Dim ccEmail As String
Dim bccEmail As String
Dim emailMessage As String
Sub GenerateInfo()
Dim WS As Worksheet
Dim lrow As Long
Dim cRow As Long
Set WS = ActiveSheet
With WS
lrow = .Range("E" & .Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
For cRow = 2 To lrow
If Not .Range("L" & cRow).value = "" Then
titleName = .Range("D" & cRow).value
firstName = .Range("E" & cRow).value
lastName = .Range("F" & cRow).value
fullName = firstName & " " & lastName
clientEmail = .Range("L" & cRow).value
Call SendEmail
.Range("Y" & cRow).value = "Yes"
.Range("Y" & cRow).Font.Color = vbGreen
Else
.Range("Y" & cRow).value = "No"
.Range("Y" & cRow).Font.Color = vbRed
End If
Next cRow
End With
Application.ScreenUpdating = True
MsgBox "Process completed!", vbInformation
End Sub
Sub SendEmail()
Dim outlookApp As Object
Dim outlookMail As Object
Dim sigString As String
Dim Signature As String
Dim insertPhoto As String
Dim photoSize As String
Set outlookApp = CreateObject("Outlook.Application")
Set outlookMail = outlookApp.CreateItem(0)
'Change only Mysig.htm to the name of your signature
sigString = Environ("appdata") & _
"\Microsoft\Signatures\Marius.htm"
If Dir(sigString) <> "" Then
Signature = GetBoiler(sigString)
Else
Signature = ""
End If
insertPhoto = "C:\Users\marius\Desktop\Presale.jpg" 'Picture path
photoSize = "<img src=""cid:Presale.jpg""height=400 width=400>" 'Change image name here
emailMessage = "<BODY style=font-size:11pt;font-family:Calibri>Dear " & titleName & " " & fullName & "," & _
"<p>I hope my email will find you very well." & _
"<p>Our <strong>sales preview</strong> starts on Thursday the 22nd until Sunday the 25th of November." & _
"<p>I look forward to welcoming you into the store to shop on preview.<p>" & _
"<p> It really is the perfect opportunity to get some fabulous pieces for the fast approaching festive season." & _
"<p>Please feel free to contact me and book an appointment." & _
"<p>I look forward to seeing you then." & _
"<p>" & photoSize & _
"<p>Kind Regards," & _
"<br>" & _
"<br><strong>Marius</strong>" & _
"<br>Assistant Store Manager" & _
"<p>"
With outlookMail
.To = clientEmail
.CC = ""
.BCC = ""
.Subject = "PRIVATE SALE"
.BodyFormat = 2
.Attachments.Add insertPhoto, 1, 0
.HTMLBody = emailMessage & Signature 'Including photo insert and signature
'.HTMLBody = emailMessage & Signature 'Only signature
.Importance = 2
.ReadReceiptRequested = True
.Display
.Send
End With
Set outlookApp = Nothing
Set outlookMail = Nothing
End Sub
Function GetBoiler(ByVal sFile As String) As String
Dim fso As Object
Dim ts As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
GetBoiler = ts.readall
ts.Close
End Function
I am not able to filter the selected mail item by Subject.
The issue is that
If TypeOf Items(1) Is Outlook.MailItem And Items(1).Restrict(sFilter) Then
is triggering the error
Run time error 438: Object doesn't support this property or method.
Steps:
Loop through cells for different subject names
Search the inbox and Sentitem folders for the latest email for selected "Subject" as sometimes people do not respond to your email. So latest email is in the sent items and not in your inbox
select the latest email and reply to all
For the body of the email, I am running another function to get the required info.
The code:
Sub AccessInbox6()
'Early binding
Dim Olook As Outlook.Application ' to access all the libraries of outlook
Set Olook = New Outlook.Application
Dim sFilter As String
Dim sSubject As String
' Restrict items and running the loop
Sheet1.Range("A2").Select
Do Until ActiveCell.Value = "" 'Using this to loop over multiple cells containing subjects
sSubject = ActiveCell.Value
sFilter = "[Subject] = '" & sSubject & "'"
Dim Items As Outlook.Items
Set Items = Olook.GetNamespace("MAPI") _
.GetDefaultFolder(olFolderInbox).Items 'Checking the inbox
Dim Items2 As Outlook.Items
Set Items2 = Olook.GetNamespace("MAPI") _
.GetDefaultFolder(olFolderSentMail).Items 'Checking the sent items
Items.Sort "ReceivedTime", True 'to put them in order by date
Items2.Sort "ReceivedTime", True 'to put them in order by date or I should use "SentOn"
'Items2.Sort "SentOn", True
If Items.Item(1).ReceivedTime > Items2.Item(1).ReceivedTime Then 'Here I am checking which email is latest by date either in inbox or SentItems
If TypeOf Items(1) Is Outlook.MailItem And Items(1).Restrict(sFilter) Then 'Getting error here - Here I am checking if the "Subject of the email matches with what I have in the excel sheet
Debug.Print Items(1).Subject ' Print on Immediate Window
With Items(1).ReplyAll
.Display
.Body = "Dear Someone" & vbNewLine & vbNewLine & GetPSMUpdate2 & vbNewLine & vbNewLine & "Sincerely," & vbNewLine & "XX-"
'.Attachments.Add Environ("UserProfile") & "\Desktop\Tracking Sheet.xlsx"
.To = "XXX#gmail.com"
.Subject = "PSM Report"
'.Send
End With
Else
MsgBox "No emails found with Subject:" & vbLf & "'" & sSubject & "'"
End If
Else
If TypeOf Items2(1) Is Outlook.MailItem And Items2(1).Restrict(sFilter) Then
Debug.Print Items(1).Subject ' Print on Immediate Window
With Items(1).ReplyAll
.Display
.Body = "Dear Someone" & vbNewLine & vbNewLine & GetPSMUpdate2 & vbNewLine & vbNewLine & "Sincerely," & vbNewLine & "XX-"
'.Attachments.Add Environ("UserProfile") & "\Desktop\Tracking Sheet.xlsx"
.To = "XXX#gmail.com"
.Subject = "PSM Report"
'.Send
End With
Else
MsgBox "No emails found with Subject:" & vbLf & "'" & sSubject & "'"
End If
End If
ActiveCell.Offset(1, 0).Select
Loop
End Sub
Function GetPSMUpdate2() As String
Dim PSMColumn As Range, PSMRow As Range, r As Range, C As Range
Dim Str As String
Sheet2.Activate
Set PSMColumn = Range("A2", Range("A1").End(xlDown))
For Each r In PSMColumn
Set PSMRow = Range(r, r.End(xlToRight))
For Each C In PSMRow
Str = Str & C.Value
If C.Column < r.End(xlToRight).Column Then
Str = Str & vbTab
End If
Next C
If r.Row < Range("A1").End(xlDown).Row Then
Str = Str & vbNewLine
End If
Next r
GetPSMUpdate2 = Str
End Function
Use of Item in the variable names causes some confusion as well the filter could be separated.
Option Explicit
Sub AccessInbox6Fix()
'Early binding
Dim Olook As outlook.Application
Dim ItemsRaw As outlook.Items
Dim Items2Raw As outlook.Items
Dim Items As outlook.Items
Dim Items2 As outlook.Items
Dim sFilter As String
Dim sSubject As String
Set Olook = New outlook.Application
Sheet1.Range("A2").Select
Do Until ActiveCell.Value = "" ' Loop over cells containing subjects
'Checking the inbox
Set ItemsRaw = Olook.Session.GetDefaultFolder(olFolderInbox).Items
Debug.Print "Raw counts"
Debug.Print " ItemsRaw.Count: " & ItemsRaw.Count
'Checking the sent items
Set Items2Raw = Olook.Session.GetDefaultFolder(olFolderSentMail).Items
Debug.Print " Items2Raw.Count: " & Items2Raw.Count
sSubject = ActiveCell.Value
sFilter = "[Subject] = '" & sSubject & "'"
Debug.Print
Debug.Print sFilter
Debug.Print "Subject counts"
Set Items = ItemsRaw.Restrict(sFilter)
Debug.Print " Items.Count: " & Items.Count
Set Items2 = Items2Raw.Restrict(sFilter)
Debug.Print " Items2.Count: " & Items2.Count
Items.Sort "SentOn", True
Items2.Sort "SentOn", True
If Items.Item(1).ReceivedTime > Items2.Item(1).ReceivedTime Then
If TypeOf Items.Item(1) Is MailItem Then
Debug.Print Items.Item(1).Subject
With Items.Item(1).ReplyAll
.Display
.To = "XXX#noplacenowhere.com"
.Subject = "PSM Report"
'.Send
End With
Else
MsgBox "Most recent item is not a mailitem:" & vbLf & "'" & sSubject & "'"
End If
Else
If TypeOf Items2.Item(1) Is outlook.MailItem Then
Debug.Print Items2.Item(1).Subject ' Print on Immediate Window
With Items2.Item(1).ReplyAll
.Display
.To = "XXX#noplacenowhere.com"
.Subject = "PSM Report"
'.Send
End With
Else
MsgBox "Most recent item is not a mailitem:" & vbLf & "'" & sSubject & "'"
End If
End If
ActiveCell.Offset(1, 0).Select
Loop
Debug.Print "Done."
End Sub
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\......"
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