I need to attach variable PDFs from a transport folder.
Sub send_attachent()
Dim OutApp As Object
Dim OutMAil As Object
Dim strbody As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMAil = OutApp.CreateItem(0)
strbody = "<BODY style = font-size:12pt; font-familt:Arial>" & _
"Please find attached High Risk Defect:<br><br> AT300-HRD-00<br><br> Issue<br><br>" & _
"Regards,<br>"
On Error Resume Next
With OutMAil
.TO = "julia.naydenova#hitachirail.com"
.CC = "jean.ash#hitachirail.com"
.BCC = ""
.Subject = "AT300-HRD-00"
.Display
.HTMLBody = strbody & .HTMLBody
.Attachments.Add "I:\ServiceDelivery\MaintenanceManuals\AT300\TRANSPORT FOLDER\AT300-HRD-00031 Test.pdf"
'You can add other files also like this
'.Attachments.Add ("C:\test.txt")
End With
MsgBox "Email Sent"
On Error GoTo 0
Set OutMAil = Nothing
End Sub
I need to send variable files, so whatever I put in the folder to be attached on the email. With the file name in the macro I can only send one file.
The Outlook object model doesn't provide anything for monitoring files in a folder on the disk. You need to create a file-watcher which can monitor files in a folder and create a new mail item when a file is added to the folder. See VBA monitor folder for new files for more information on that.
Loop through files in a folder with Dir.
Option Explicit
Sub send_all_PDF_folder()
Dim outApp As Object
Dim outMail As Object
Dim strbody As String
Dim filePath As String
Dim fileName As String
Set outApp = CreateObject("Outlook.Application")
Set outMail = outApp.CreateItem(0)
strbody = "<BODY style = font-size:12pt; font-familt:Arial>" & _
"Please find attached High Risk Defect:<br><br> AT300-HRD-00<br><br> Issue<br><br>" & _
"Regards,<br>"
filePath = "I:\ServiceDelivery\MaintenanceManuals\AT300\TRANSPORT FOLDER"
With outMail
.To = "someone#somewhere.com"
.CC = "someoneCC#somewhere.com"
.Subject = "AT300-HRD-00"
.Display
.HtmlBody = strbody & .HtmlBody
fileName = dir(filePath & "\*.pdf")
Do While fileName <> ""
.Attachments.Add filePath & fileName
fileName = dir
Loop
End With
Set outMail = Nothing
Set outApp = Nothing
End Sub
Related
I was trying to use the following code to insert a "Click here" link to link to the document that is open but I am having an issue.
When the email has been drafted and the link is inserted, only some of the hyperlink is carried over to the email, meaning that the hyperlink does not work.
I am trying the following to do this:
Private Sub Completion_Notification()
Dim xInspect As Object
Dim pageEditor As Object
Dim Strbody As String
Dim CommentsPath As String
Dim CommentsName As String
CommentsName = ActiveWorkbook.Name
CommentsPath = Application.ActiveWorkbook.FullName
Strbody = "Click Here"
'Getting the email List
Dim i As Integer
Dim Email_Rng As Range
Dim Num_of_Emails As Integer
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = "Email"
.CC = ""
.Subject = "Email_Subject"
.HTMLBody = "<html><p>Hi, " & "</p>" & _
"<p>" & Strbody & _
"<p>" & "Many Thanks"
.Display
'.Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
However, when I step into the code and check the value for the "strbody" expression the link is there in full so I have no idea why this would not be working. is there a Limit to the number of characters that can be inserted into the href?
To represent a link to a local file, Use <A HREF=""file://
Example
Option Explicit
Public Sub example()
Dim Strbody As String
Strbody = "<A HREF=""file://" & _
Application.ActiveWorkbook.FullName & _
""">Click Here</A>"
Dim OutApp As Object
Set OutApp = CreateObject("Outlook.Application")
Dim OutMail As Object
Set OutMail = OutApp.CreateItem(0)
With OutMail
.HTMLBody = "<html><p>Hi, " & "</p>" & _
"<p>" & Strbody & _
"<p>" & "Many Thanks"
.Display
'.Send
End With
End Sub
I have a converted document from .docx into .pdf saved to the desktop. The last task is to attach this .pdf to the body of an e-mail; the HTML signature should remain unchanged.
I think the problem is this line of code and I don't know how to correct it:
.Attachments.Add PdfFile.FullName
The complete code:
Public Sub Mail()
Dim LastAuthor As String
LastAuthor = ActiveDocument.BuiltInDocumentProperties("last Author")
Dim Email As String
Email = Replace(LastAuthor, " ", ".") & "#xyz.ro"
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.Display
.Signature = "HTMLbody"
.To = Email
.CC = ""
.BCC = ""
.Subject = ActiveDocument.Name
'.Body = "AVIZAT. Multumesc mult"
'.Attachments.Add ActiveDocument.FullName
' You can add other files by uncommenting the following line.
'.Attachments.Add ("C:\test.txt")
' In place of the following statement, you can use ".Display" to
' display the mail.
.HTMLbody = "AVIZAT, esantionul este in ordine. Multumesc" & "<br>" & .HTMLbody
Dim objDoc As Document
Set objDoc = ActiveDocument
objDoc.ExportAsFixedFormat _
OutputFileName:=Replace(objDoc.FullName, ".docx", ".pdf"), _
ExportFormat:=wdExportFormatPDF, OpenAfterExport:=False, OptimizeFor:=wdExportOptimizeForPrint, _
Range:=wdExportAllDocument, Item:=wdExportDocumentContent
' Add the attachment first for correct attachment's name with non English symbols
.Attachments.Add PdfFile.FullName
'.Preview 'Preview the email must disable .send & MsgBox (or use .Send to send it)
.send
MsgBox "E-mail trimis cu succes"
Set OutMail = Nothing
Set OutApp = Nothing
End With
End Sub
This will do:
Public Sub Mail()
Dim LastAuthor As String
Dim Email As String
Dim MyPdfName As String
Dim objDoc As Document
LastAuthor = ActiveDocument.BuiltinDocumentProperties("last Author")
Email = Replace(LastAuthor, " ", ".") & "#xyz.ro"
Set objDoc = ActiveDocument
MyPdfName = Replace(objDoc.FullName, ".docx", ".pdf")
objDoc.ExportAsFixedFormat _
OutputFileName:=MyPdfName, _
ExportFormat:=wdExportFormatPDF, OpenAfterExport:=False, OptimizeFor:=wdExportOptimizeForPrint, _
Range:=wdExportAllDocument, Item:=wdExportDocumentContent
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.Display
.To = Email
.CC = ""
.BCC = ""
.Subject = objDoc.Name
.HTMLBody = "<BODY style=font-size:12pt;font-family:Calibri>Servus<br>Esantionul este in ordine.<br><br>Multumesc,<br>" & .HTMLBody
.Attachments.Add MyPdfName
.Send
End With
Set OutMail = Nothing
Set OutApp = Nothing
MsgBox "E-mail trimis cu succes"
End Sub
It's far from perfect but is a lot clearer now and most importantly, works.
Got a macro running through columns with mail addresses using most parts from Ron de Bruin.
The macro runs through just fine, but only sends the first hit in column B and doesn't display any of the other hits when i try to watch it? What could be the issue?
The code is so that I can get the default signature from outlook, thats why it's .Display first in the code.
Sub mail_HTML()
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
'Working in Office 2000-2016
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Dim strbody As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error GoTo cleanup
For Each cell In Columns("B").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*#?*.?*" And _
LCase(Cells(cell.Row, "C").Value) = "yes" Then
strbody = "<H3>Hei " & Cells(cell.Row, "E").Value & "</H3>" _
& "<p>" & Range("k4") & "<p>"
On Error Resume Next
With OutMail
.Display
.To = cell.Value
.Subject = Range("K12").Value
.HTMLBody = strbody & .HTMLBody
'You can add files also like this
'.Attachments.Add Range("O1").Value
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
End If
Next cell
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub
When you set
Set OutMail = Nothing
You dont have any access to the object anymore (because it is destroyed). But you set it before the loop. You need to set it in every loop then like this:
On Error Resume Next
Set OutMail = OutApp.CreateItem(0)
With OutMail
.Display
.To = cell.Value
.Subject = Range("K12").Value
.HTMLBody = strbody & .HTMLBody
'You can add files also like this
'.Attachments.Add Range("O1").Value
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
So after 1 Email the oject is destroyed, but you are not aware because of the on error resume next
Tried that but it is not working for me, here is my code:
Do Until in_file.EOF
Email_To = in_file!email_address
Email_Bcc = ""
Email_Body = in_file!email_salut & " " & in_file!email_name & ", test this."
Email_Subject = "Email Subject"
Set mail_object = CreateObject("Outlook.Application")
Set mail_single = mail_object.CreateItem(0)
With mail_single
.Subject = Email_Subject
.To = Email_To
.cc = Email_Cc
.BCC = Email_Bcc
.Body = Email_Body
.send
End With
Set mail_object = Nothing
Set mail_single = Nothing
in_file.MoveNext
Loop
I have a vba code which works fine, but I want to create the same code as batch file which can do the same thing the vba code is doing.
I have created the code which sends all files in a folder to a specified email address and after sending delete the file.
Can anyone help me in creating the same thing with a batch file which can do the same thing.
Below is the VBA code:
Private Sub Click()
Dim mess_body As String, StrFile As String, StrPath As String
Dim appOutLook As Outlook.Application
Dim MailOutLook As Outlook.MailItem
Set appOutLook = CreateObject("Outlook.Application")
Set MailOutLook = appOutLook.CreateItem(olMailItem)
'~~> Change path here
StrPath = "\Project\New folder\New folder\"
With MailOutLook
.BodyFormat = olFormatRichText
.To = "test#sdm.com"
.Subject = "test"
.HTMLBody = "test"
'~~> *.* for all files
StrFile = Dir(StrPath & "*.*")
Do While Len(StrFile) > 0
.Attachments.Add StrPath & StrFile
StrFile = Dir
Loop
'.DeleteAfterSubmit = True
.Send
End With
Kill "\Project\New folder\New folder\*.*"
MsgBox "Reports have been sent", vbOKOnly
End Sub
U can use cell ("A1") value as folder reference.
Dim objFolder As Object
Set appOutLook = CreateObject("Outlook.Application")
Set MailOutLook = appOutLook.CreateItem(olMailItem)
'~~> Change path here
VAR1 = Range("A1").Value
If VAR1 = False Then MsgBox "Cell is empty"
If VAR1 = False Then Exit Sub
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(VAR1)
With MailOutLook
.BodyFormat = olFormatRichText
.To = "test#test.com"
.Subject = "test"
.HTMLBody = "test"
'~~> *.* for all files
StrFile = Dir(objFolder & "*.*")
...
'.DeleteAfterSubmit = True
.Send
End With
'delete files
Kill objFolder & "\*.*"
I have an Excel Document in a Template. Users input information and Save As a new genericized number. They then hit a button that auto populates an email to one of 5 people using Vlookup and based on the cost margin.
The file is Save As'd but the e-mail recipient cannot open the file, it reads invalid location. I can close and reopen the new renamed sheet and drag it into an e-mail. I need to link to the newly saved file's name that appears in the email.
Sub Email_created_Workbook()
Dim OutApp As Object
Dim OutMail As Object
Dim Mess As Object, Recip
Recip = [Sheet1!B28].Value & "; " & [Sheet1!B27].Value
Dim strbody As String
If ActiveWorkbook.Path <> "" Then
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strbody = "<font size=""3"" face=""Calibri"">" & _
"Hello,<br><br>" & _
"There is a New PO awaiting your approval :<br><B>" & _
ActiveWorkbook.Name & "</B> is created.<br>" & _
"Click on this link to open the file : " & _
"<A HREF=""file://" & ActiveWorkbook.FullName & _
""">Link to Workbook</A>" & _
"<br><br>Regards," & _
"<br><br>Automated Approval System</font>"
On Error Resume Next
With OutMail
.To = Recip
.CC = ""
.BCC = ""
.Subject = ActiveWorkbook.Name
.HTMLBody = strbody
.Display 'or use .Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
Else
MsgBox "The ActiveWorkbook does not have a path, Save the file first."
End If
End Sub
The file name does adapt in my e-mail, from PO Template, but will not open.
I believe this will help you with your current issue (closing and reopening your file before sending). I've removed the the two lines of your code where you set the Outlook objects to Nothing. To reopen the current file you can use the OnTime function like so:
Sub Email_created_Workbook()
Dim OutApp As Object
Dim OutMail As Object
Dim Mess As Object, Recip
Recip = [Sheet1!B28].Value & "; " & [Sheet1!B27].Value
Dim strbody As String
If ActiveWorkbook.Path <> "" Then
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strbody = "<font size=""3"" face=""Calibri"">" & _
"Hello,<br><br>" & _
"There is a New PO awaiting your approval :<br><B>" & _
ActiveWorkbook.Name & "</B> is created.<br>" & _
"Click on this link to open the file : " & _
"<A HREF=""file://" & ActiveWorkbook.FullName & _
""">Link to Workbook</A>" & _
"<br><br>Regards," & _
"<br><br>Automated Approval System</font>"
On Error Resume Next
With OutMail
.To = Recip
.CC = ""
.BCC = ""
.Subject = ActiveWorkbook.Name
.HTMLBody = strbody
.Display 'or use .Send
End With
Application.OnTime Now + TimeValue("00:00:10"), "SendEmail"
ThisWorkbook.Close True 'True= yes, save changes
Else
MsgBox "The ActiveWorkbook does not have a path, Save the file first."
End If
End Sub
Sub SendEmail()
Dim OutApp As Object: Set OutApp = GetObject(, "Outlook.Application") 'Grab current instance of Outlook since we already opened the instance prior to restarting Excel
Dim oInspector As OutApp.Inspector: Set oInspector = OutApp.ActiveInspector
Dim NewMail As OutApp.MailItem: Set NewMail = oInspector.CurrentItem 'Grab currently open New/Compose Mail window
NewMail.Send 'Send Email
End Sub
Let me know if this helps resolve your issue.