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.
I have column "AB" that has a hyperlink in which I will like to include in a email through VBA.
The hyperlink changes per line. I am able to pull the column through text however the email is not showing the hyper link.
How can I get it to show as a hyperlink?
Dim OutApp As Object
Dim OutMail As Object
Dim strto As String, strcc As String, strbcc As String
Dim strsub As String, strbody As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strto = Cells(FormulaCell.Row, "Y").Value
strcc = ""
strbcc = ""
strsub = "MCR FORM"
strbody = "Hi " & Cells(FormulaCell.Row, "O").Value & vbNewLine & vbNewLine & _
"You have a open MCR that needs attention. Please Find the attachted MCR Form for material : " & Cells(FormulaCell.Row, "E").Value & _
vbNewLine & vbNewLine & Cells(FormulaCell.Row, "AB").Value & vbNewLine & vbNewLine & "Thank you!"
With OutMail
.To = strto
.CC = strcc
.BCC = strbcc
.Subject = strsub
.Body = strbody
'You can add a file to the mail like this
.Attachments.Add ("P:\Inventory Control\Public\MCR Form Master.xlsm")
.Display ' or use .Send
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
vbNewLine & vbNewLine & Cells(FormulaCell.Row, "AB").Value &
I believe the code above needs to be reference a HREF link??
Work with HTMLBody Property
Example will show Hyperlink Click Here
.HTMLBody = " Click Here "
Or This will show the value A1 as link
"" & Sht.Range("A1") & "" &
Full Code
Option Explicit
Public Sub Example()
Dim Sht As Excel.Worksheet
Set Sht = ThisWorkbook.Worksheets("Sheet1")
Dim OutApp As Object
Set OutApp = CreateObject("Outlook.Application")
Dim OutMail As Object
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = ""
.CC = ""
.BCC = ""
.Subject = ""
.HTMLBody = "Hi " & vbNewLine & vbNewLine & _
"You have a open MCR that needs attention. " & _
vbNewLine & vbNewLine & _
" Click Here " & _
vbNewLine & vbNewLine & _
"Thank you!"
'You can add a file to the mail like this
.Display ' or use .Send
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Option Explicit Statement (Visual Basic)
Forces explicit declaration of all variables in a file, or allows implicit declarations of variables.
I have a few VBA macros that don't work since I installed the 2016 version of Office.
It's the bit to display a pre-typed email that doesn't work. The rest of the code runs as it should.
Sub Send_Application()
Application.ScreenUpdating = False
For Each cell In ActiveSheet.Range("NumberOfApps").Cells
If cell.Value = "Y" Then
cell.Offset(0, -1).Value = Worksheets("Data").Range("A2")
cell.Value = "SENT"
cell.Offset(0, 18).Value = "Yes"
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Dim sTo As String
AppName = "J:\Matrixes\All Sites\Applications\" & Worksheets("Data").Range("E3") & "\" & cell.Offset(0, 13).Value & ".pdf"
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strbody = Worksheets("Data").Range("G2") & vbNewLine & vbNewLine & _
"Please find attached our application for payment for the month of " & Worksheets("Data").Range("E2") & "." & vbNewLine & vbNewLine & _
"Can I ask you to check you are happy with this application and I will issue an Vat Invoice to you. If you do have any queries can you please notify me by email before the 15th " & _
Worksheets("Data").Range("E4") & " otherwise we look forward receiving your payment " & Worksheets("Data").Range("E6") & "." & vbNewLine & vbNewLine & _
"Thank You" & vbNewLine & vbNewLine & _
"Kind Regards"
On Error Resume Next
With OutMail
.To = sTo
.CC = ""
.BCC = ""
.Subject = cell.Offset(0, 13).Value
.Body = strbody
.Attachments.Add (AppName)
'You can add a file like this
'.Attachments.Add ("C:\test.txt")
.Display 'or use .Display
End With
'On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End If
Next cell
Application.ScreenUpdating = True
End Sub
I have commented out the "On Error Resume" lines but there are no errors that appear.
I have run Excel and Outlook as administrator, enabled all macros temporarily in both.
If I write a brand new macro using the same text, it works until I close Excel. Then I need to do it again.
I searched for a solution but everything I tried hasn't worked.
With you code do the following:
Select the Sub Send_Application() with your mouse
Press F8
Press F8
Press F8
and so on. You should be getting every line in yellow like this:
Does it work?
I wonder whether someone could help me please.
I'm trying to write a script which send multiple emails to addressees on a spreadsheet, with various other pieces of information.
I've started to use a solution from Ron de Bruin (below).
Sub Email()
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Dim Src As Worksheet
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
Set Src = ThisWorkbook.Sheets("List")
On Error GoTo cleanup
Src.Select
For Each cell In Columns("C").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*#?*.?*" Then
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = cell.Value
.Subject = "Splunk Access"
.Body = "Hi " & Cells(cell.Row, "A").Value _
& vbNewLine & vbNewLine & _
"I have created an account: Production." & _
vbNewLine & vbNewLine & _
"Your username and password for this environment is:" & _
vbNewLine & vbNewLine & _
"Username: " & Cells(cell.Row, "B").Value & _
vbNewLine & _
"Password: " & Cells(cell.Row, "E").Value & _
vbNewLine & vbNewLine & _
"Please log in at your earliest convenience and change your password to a more secure one. " & _
vbNewLine & vbNewLine & _
"You can do this by clicking on your name on the top menu and select ‘Edit Account’." & _
vbNewLine & vbNewLine & _
"You can use this link to get to the log in page for this environment: " & _
vbNewLine & vbNewLine & _
"PROD: right/en-US/account/logout " & _
vbNewLine & vbNewLine & _
"Many thanks and kind regards"
.send
End With
On Error GoTo 0
Set OutMail = Nothing
End If
Next cell
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub
This script works, but I then receive the 'Outlook' security ,message, which with over 100 recipients, isn't practical to keep pressing "Ok" to send the email.
So following more research I changed:
.send
to
.Display
Application.Wait (Now + TimeValue("0:00:01"))
Application.SendKeys "%"
But the problem I have is that the email is created, but isn't sent. Again not practical to keep pressing "Send" for over 100 users.
I then tried a CDO solution, but I ran into problems with the SMTP address because I'm using my works Microsoft Exchange which I'm not an administrator for, and so don't have any of the SMTP details.
I just wondered whether someone may be able to look a this please, and offer some guidance on how I can create the macro to run automatically.
Many thanks and kind regards
Chris
All,
I managed to get this working with the following:
Sub Email()
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Dim Src As Worksheet
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
Set Src = ThisWorkbook.Sheets("List")
On Error GoTo cleanup
Src.Select
For Each cell In Columns("C").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*#?*.?*" Then
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = cell.Value
.Subject = "Access"
.Body = "Hi " & Cells(cell.Row, "A").Value _
& vbNewLine & vbNewLine & _
"I have created an account for you" & _
vbNewLine & vbNewLine & _
"Your username and password for this environment is:" & _
vbNewLine & vbNewLine & _
"Username: " & Cells(cell.Row, "B").Value & _
vbNewLine & _
"Password: " & Cells(cell.Row, "E").Value & _
vbNewLine & vbNewLine & _
"Please log in at your earliest convenience and change your password to a more secure one. " & _
vbNewLine & vbNewLine & _
"You can do this by clicking on your name on the top menu and select 'Edit Account'." & _
vbNewLine & vbNewLine & _
"You can use this link to get to the log in page for this environment: " & _
vbNewLine & vbNewLine & _
"PROD: https://right/en-US/account/logout " & _
vbNewLine & vbNewLine & _
"Many thanks and kind regards"
' .send
.Display
Application.Wait (Now + TimeValue("0:00:02"))
Application.SendKeys "%s"
Application.SendKeys "+o"
End With
On Error GoTo 0
Set OutMail = Nothing
End If
Next cell
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub
I found through further testing, that a automatic pop up appeared when the 'Send' button was clicked by this command Application.SendKeys "%s", so I added Application.SendKeys "+o2, to automatically click "OK".
Kind regards
Chris
try
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
this is of course using .Send
make sure to turn them back on at end of sub
So I'm in need of some help. I'm trying to update my company's Excel tool that they use to manage clients. I currently need help with updating the Send Email function of the tool. So employees will have a list of clients they need to send an email to, and each client will have specific information like name, client number, etc., and the employees should be able to click the "Send Email" macro button that's built in, and different emails will populate in Outlook with the specific info for each client built into the Email recipient, Title and Body.
I am currently stuck. For example, I will choose 3 clients to send an email to, click the "Send Email" button, and I will get 3 emails to populate (as I should). The first email will have all of the correct info in the right place for Client #1. However, Email #2 will have the correct Email Recipient & Email Title, but then the Email Body will have the correct info for Client #2, and below that also in the Email Body will be all of the email body info for Client #1. And same for Email #3, it will have the correct recipient and title, but the Body will have body info for Client #3, then Client #2, then Client #1.
So I know that I need to fix it through some sort of loop for the email body, but I have been working on this for so long I just can't see it anymore. I've removed any sensitive information and put in placeholders, but I think you should get the idea.
Please let me know if you have any questions.
Sub SendEMail()
Dim Email As String
Dim Subj As String
Dim Msg As String
Dim URL As String
Dim r As Integer
Dim x As Double
Dim OApp As Object
Dim OMail As Variant
Dim Signature As String
Dim strbody As String
strbody = "<html><body>"
With Sheets("Email").Select
lastrow = Cells(Rows.Count, "B").End(xlUp).Row
End With
For r = 2 To lastrow
Set OApp = CreateObject("Outlook.Application")
Set OMail = OApp.CreateItem(0)
' Get the email address
Sheets("Email").Select
Email = Cells(r, "F")
' Message subject
Sheets("Email").Select
Subj = "Renewal for " & Cells(r, "B").Text & " Contract " & Cells(r, "A").Text & " Effective " & Cells(r, "C").Text
' Message body
Sheets("Email").Select
strbody = strbody & "Dear " & Cells(r, "AR").Text & ", <br><br>" & _
"I will be working with you on " & Cells(r, "B") & ", client number " & Cells(r, "A") & ", which is effective " & Cells(r, "C") & ".<br><br>" & _
"For this year's contract, we are requesting the following information: <br>" & _
"<li>" & Cells(r, "AH") & "</li>" & "<br><br>" & _
"The application form may be downloaded from:<br>" & _
"<li>Option #1</li>: " & "" & "Link#1" & "" & "<br>" & _
"<li>Option #2</li>: " & "" & "link#2" & "" & "<br><br>" & _
"Once we receive the requested information, you will receive your contract within 5 business days. Should you have any questions, please don't hesitate to contact me at this email address or phone number <br><br>" & _
"As always, we would like to thank you for your business. <br><br>" & _
"Regards, <br>"
On Error Resume Next
Sheets("Email").Select
With OMail
.Display
.To = Email
.Subject = Subj
.HTMLBody = strbody & vbNewLine & .HTMLBody
End With
Next r
On Error GoTo 0
Set OMail = Nothing
Set OApp = Nothing
End Sub
Please take a look at this example.
In column A : Names of the people
In column B : E-mail addresses
In column C:Z : Filenames like this C:\Data\Book2.xls (don't have to be Excel files)
The Macro will loop through each row in "Sheet1" and if there is a E-mail address in column B
and file name(s) in column C:Z it will create a mail with this information and send it.
Sub Send_Files()
'Working in Excel 2000-2016
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
Dim OutApp As Object
Dim OutMail As Object
Dim sh As Worksheet
Dim cell As Range
Dim FileCell As Range
Dim rng As Range
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set sh = Sheets("Sheet1")
Set OutApp = CreateObject("Outlook.Application")
For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
'Enter the path/file names in the C:Z column in each row
Set rng = sh.Cells(cell.Row, 1).Range("C1:Z1")
If cell.Value Like "?*#?*.?*" And _
Application.WorksheetFunction.CountA(rng) > 0 Then
Set OutMail = OutApp.CreateItem(0)
With OutMail
.to = cell.Value
.Subject = "Testfile"
.Body = "Hi " & cell.Offset(0, -1).Value
For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
If Trim(FileCell) <> "" Then
If Dir(FileCell.Value) <> "" Then
.Attachments.Add FileCell.Value
End If
End If
Next FileCell
.Send 'Or use .Display
End With
Set OutMail = Nothing
End If
Next cell
Set OutApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
You can learn more about it from the link below.
http://www.rondebruin.nl/win/s1/outlook/amail6.htm
If you want to use this macro instead of a mail merge the problem you are having is here:
strbody = strbody & "Dear " & Cells(r, "AR").Text & ", <br><br>" & _
"I will be working with you on " & Cells(r, "B") & ", client number " & Cells(r, "A") & ", which is effective " & Cells(r, "C") & ".<br><br>" & _
"For this year's contract, we are requesting the following information: <br>" & _
"<li>" & Cells(r, "AH") & "</li>" & "<br><br>" & _
"The application form may be downloaded from:<br>" & _
"<li>Option #1</li>: " & "" & "Link#1" & "" & "<br>" & _
"<li>Option #2</li>: " & "" & "link#2" & "" & "<br><br>" & _
"Once we receive the requested information, you will receive your contract within 5 business days. Should you have any questions, please don't hesitate to contact me at this email address or phone number <br><br>" & _
"As always, we would like to thank you for your business. <br><br>" & _
"Regards, <br>"
This takes the variable strbody and adds the rest of the string to it.
Update it to:
strbody = "Dear " & Cells(r, "AR").Text & ", <br><br>" & _
"I will be working with you on " & Cells(r, "B") & ", client number " & Cells(r, "A") & ", which is effective " & Cells(r, "C") & ".<br><br>" & _
"For this year's contract, we are requesting the following information: <br>" & _
"<li>" & Cells(r, "AH") & "</li>" & "<br><br>" & _
"The application form may be downloaded from:<br>" & _
"<li>Option #1</li>: " & "" & "Link#1" & "" & "<br>" & _
"<li>Option #2</li>: " & "" & "link#2" & "" & "<br><br>" & _
"Once we receive the requested information, you will receive your contract within 5 business days. Should you have any questions, please don't hesitate to contact me at this email address or phone number <br><br>" & _
"As always, we would like to thank you for your business. <br><br>" & _
"Regards, <br>"
And it will overwrite it each time which is what I think you want.
Also you don't need to select the sheet each time (or at all really). Selecting sheets, cells, etc is generally bad coding practice that can significantly slow down your code.