Cannot attach workbook to send by vba button - vba

I have some vba code, which I have attached to a excel button. When pressing the button the outlook mail box will appear- ready to send the mail. But for some reason the workbook is not attached to the mail. In the code below - I think something is wrong with add.attachments. at the end
My VBA code is:
Dim xRg As Range
Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Target.Cells.Count > 1 Then Exit Sub
Set xRg = Intersect(Range("D7"), Target)
If xRg Is Nothing Then Exit Sub
If IsNumeric(Target.Value) And Target.Value > 200 Then
Call Mail_small_Text_Outlook
End If
End Sub
Sub Mail_small_Text_Outlook()
Dim xOutApp As Object
Dim xOutMail As Object
Dim xMailBody As String
Set xOutApp = CreateObject("Outlook.Application")
Set xOutMail = xOutApp.CreateItem(0)
xMailBody = "Hi there" & vbNewLine & vbNewLine & _
"This is line 1" & vbNewLine & _
"This is line 2"
On Error Resume Next
With xOutMail
.To = "Email Address"
.CC = ""
.BCC = ""
.Subject = "send by cell value test"
.Body = xMailBody
.Attachments.Add "W\Desktop\Files\Workbook1
.Display 'or use .Send
End With
On Error GoTo 0
Set xOutMail = Nothing
Set xOutApp = Nothing
End Sub

The following line of code is not complete:
.Attachments.Add "W\Desktop\Files\Workbook1
The Add method of the Attachments class creates a new attachment in the Attachments collection. The source of the attachment can be a file (represented by the full file system path with a file name), for example:
.Attachments.Add "C:\Test.xslx", olByValue, 1, "Test"
I'd also suggest specifying a local file path.

Related

Sending automatic email to email address based on cell value in row

I want to send automatic email from Excel though Outlook subject to the condition that the value in a column is greater than 2, and retrieve specific cells from the same row in which the conditions is true.
Furthermore, how can I send it to an email address saved in one of the cells within that row?
Dim xRg As Range
'Update by Extendoffice 2018/3/7
Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Target.Cells.Count > 1 Then Exit Sub
Set xRg = Intersect(Range("D7:D1000"), Target)
If xRg Is Nothing Then Exit Sub
If IsNumeric(Target.Value) And Target.Value > 2 Then
Call Mail_small_Text_Outlook
End If
End Sub
Sub Mail_small_Text_Outlook()
Dim xOutApp As Object
Dim xOutMail As Object
Dim xMailBody As String
Set xOutApp = CreateObject("Outlook.Application")
Set xOutMail = xOutApp.CreateItem(0)
xMailBody = "Hi there" & vbNewLine & vbNewLine & _
"This is line 1" & vbNewLine & _
"This is line 2"
On Error Resume Next
With xOutMail
.To = "Email Address"
.CC = ""
.BCC = ""
.Subject = "send by cell value test"
.Body = xMailBody
.Display 'or use .Send
End With
On Error GoTo 0
Set xOutMail = Nothing
Set xOutApp = Nothing
End Sub
With xOutMail
.To = Cells(xRg.Row,"A") ' column A
.CC = ""
.BCC = ""
.Subject = "send by cell value test"
.Body = xMailBody
.Display 'or use .Send
End With

VBA Send email when cell changes using Worksheet_Calculate

So my code loops through a range of cells and triggers an email on the condition that, in this example, N150 = F150. This works, the email is sent. But what I'm finding difficult is referencing the changed cell in the email body. You can see within the xMailBody variable I have tried cll.Offset(0, -12) so when N150 = F150 I am given the cell value 12 columns to the left which should be B150. Instead I am getting the value of B145 which is correct in that it's the right column but obviously the incorrect row. My target range is N145:N160 so I think it's only referecing the first row in my range. Any help would be greatly appreciated been trying to figure this out for days!
Dim target As Range
Dim cll As Range
Private Sub Worksheet_Calculate()
Set target = Range("N145:N160")
For Each cll In target
If (Range("N150") = Range("F150"))
Call Mail_small_Text_Outlook(target)
Exit For
End If
Next
End Sub
Sub Mail_small_Text_Outlook()
Dim xOutApp As Object
Dim xOutMail As Object
Dim xMailBody As String
Set xOutApp = CreateObject("Outlook.Application")
Set xOutMail = xOutApp.CreateItem(0)
xMailBody = "Hi there" & vbNewLine & vbNewLine & _
cll.Offset(0, -12) & " has reached its target"
On Error Resume Next
With xOutMail
.To = "email"
.CC = ""
.BCC = ""
.Subject = "Target Reached"
.Body = xMailBody
.Send 'or use .Display
End With
On Error GoTo 0
Set xOutMail = Nothing
Set xOutApp = Nothing
End Sub
You are looping from N145:N160 but only checking if Range("N150") = Range("F150"). If that check is true it will be true on the first iteration when cll is N145 so the email is sent and the loop exits so no other cll is processed.
...
Set target = Range("N145:N160")
For Each cll In target
If cll = cll.offset(0, -12) then
'cll is public, no need to pass it or target across
Mail_small_Text_Outlook
Exit For
End If
Next
...
Instead of using a global variable, pass the value you want in the email as a parameter for your Mail_small_Text_Outlook function.
Dim target As Range
Private Sub Worksheet_Calculate()
Dim FoundCell as String
Set target = Range("N145:N160")
For Each cll In target
If (Range("N150") = Range("F150"))
FoundCell = Cstr(cll.Offset(0, -12).Value2)
Call Mail_small_Text_Outlook(FoundCell)
Exit For
End If
Next
End Sub
Sub Mail_small_Text_Outlook(FoundCell as String)
Dim xOutApp As Object
Dim xOutMail As Object
Dim xMailBody As String
Set xOutApp = CreateObject("Outlook.Application")
Set xOutMail = xOutApp.CreateItem(0)
xMailBody = "Hi there" & vbNewLine & vbNewLine & _
FoundCell & " has reached its target"
On Error Resume Next
With xOutMail
.To = "email"
.CC = ""
.BCC = ""
.Subject = "Target Reached"
.Body = xMailBody
.Send 'or use .Display
End With
On Error GoTo 0
Set xOutMail = Nothing
Set xOutApp = Nothing
End Sub
Now you can watch the value of FoundCell prior to passing it into the function, making your debugging process far easier.

Send SECURE email with Outlook via VBA

I have a simple code to open Microsoft Outlook and send an email with an attachment. I would like to send the email securely. Meaning, I would like to know if there is any code that would be tantamount to pressing the "Send Securely" button in outlook. Here is my code so far.....
Sub EmailInvoice()
Dim OutlookApp As Object, OutlookMessage As Object
Dim FileName As String, EmailAddress As String
EmailAddress = Range("ProviderEmail").Value
FileName = "C:\Users\rblahblahblah.txt"
Set OutlookApp = GetObject(class:="Outlook.Application") 'Handles if
Outlook is already open
Err.Clear
If OutlookApp Is Nothing Then Set OutlookApp =
CreateObject(class:="Outlook.Application") 'If not, open Outlook
If Err.Number = 429 Then
MsgBox "Outlook could not be found, aborting.", 16, "Outlook Not Found"
Exit Sub
End If
'Create a new email message
Set OutlookMessage = OutlookApp.CreateItem(0)
'Create Outlook email with attachment
With OutlookMessage
.To = EmailAddress
.CC = ""
.BCC = ""
.Subject = "Invoice for Upload - " & Month
.Body = "Please upload the attached file to the Vendor Portal."
.Attachments.Add FileName
.Display
.Send
End With
End Sub
The code below will send it with a sensitivity enumeration but not securely (Certified Mail). I also add my signature (Default) to the email.
Sub Mail_workbook_Outlook_1()
'Working in Excel 2000-2013
'This example send the last saved version of the Activeworkbook
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Dim SigString As String
Dim Signature As String
For Each cell In ThisWorkbook.Sheets("Email List").Range("B1:B100")
If cell.Value Like "?*#?*.?*" And LCase(cell.Offset(0, 1).Value) = "yes" Then
strto = strto & cell.Value & ";"
End If
Next cell
If Len(strto) > 0 Then strto = Left(strto, Len(strto) - 1)
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
'Change only Mysig.htm to the name of your signature
SigString = Environ("appdata") & "\Microsoft\Signatures\Default.htm"
If Dir(SigString) <> "" Then
Signature = GetBoiler(SigString)
Else
Signature = ""
End If
On Error Resume Next
With OutMail
.to = strto
.CC = ""
.BCC = ""
.Subject = ("*Confidential*: Policyholder Name Here - Policy # Here - Premium Bill")
.HTMLBody = "Attached is the most recent premium bill in Excel." & "<br><br>" & Signature
.Attachments.Add ActiveWorkbook.FullName
'You can add other files also like this
'.Attachments.Add ("C:\test.txt")
.Importance = 2 '(0=Low, 1=Normal, 2=High)
.Sensitivity = 3 '(0=Normal, 1=Personal, 2=Private, 3=Confidential)
.Send 'or use .Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Function GetBoiler(ByVal sFile As String) As String
'Dick Kusleika
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

If there is no attachment file is present at path mail should not send

If there is no attachment file is present at path mail should not send.
Is there any possibility that mail should not be send if there is no attachment?
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strbody = " Hello"
On Error Resume Next
With OutMail
.to = "test#gmail.com"
.cc = "test1#gmail.com"
.BCC = ""
.Subject = "TRANSACTING : " & Format(Date, "DD-MMM-YYYY")
.HTMLBody = strbody
'You can add an attachment like this
.Attachments.Add ("E:\Auto Reports\test.xlsb")
.send 'or use .Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
First of all using On Error Resume Next in the way you did just mute any errors. But the errors still occur they just don't show. Using On Error Resume Next is a very bad practice and you should avoid that unless you really know why you need to do it.
Instead you should always implement a proper error handling like below.
Now the error is shown if adding an attachment to the email fails and the email is not sent.
Option Explicit
Public Sub SendMyEMail()
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strbody = " Hello"
On Error GoTo MAIL_ERROR 'jump to the error handler if an error occurs
With OutMail
.to = "test#gmail.com"
.cc = "test1#gmail.com"
.BCC = ""
.Subject = "TRANSACTING : " & Format(Date, "DD-MMM-YYYY")
.HTMLBody = strbody
'You can add an attachment like this
.Attachments.Add ("C:\Auto Reports\test.xlsb")
.send 'or use .Display
End With
On Error GoTo 0 'stop error handling here (no jumps to the error handler anymore.
'The following 2 lines can be omitted because it is done automatically on exit sub
'So these are completely unnecessary.
'Set OutMail = Nothing
'Set OutApp = Nothing
Exit Sub 'we need this to not to run into error handler if everything was ok
MAIL_ERROR: 'Show error message
MsgBox "An error occured during sending the email. The email was not sent: " & vbNewLine & Err.Description, vbCritical, "Error " & Err.Number, Err.HelpFile, Err.HelpContext
End Sub
Send multiple different e-mails
To send multiple different e-mails you need to make your procedure a more universal function receiving some parameters.
Public Function SendMyEMail(MailTo As String, MailCC As String, MailSubject As String, MailFileName As String)
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strbody = " Hello"
On Error GoTo MAIL_ERROR 'jump to the error handler if an error occurs
With OutMail
.To = MailTo
.CC = MailCC
.BCC = ""
.Subject = MailSubject
.HTMLBody = strbody
'You can add an attachment like this
.Attachments.Add MailFileName
.send 'or use .Display
End With
On Error GoTo 0 'stop error handling here (no jumps to the error handler anymore.
'The following 2 lines can be omitted because it is done automatically on exit sub
'So these are completely unnecessary.
'Set OutMail = Nothing
'Set OutApp = Nothing
Exit Function 'we need this to not to run into error handler if everything was ok
MAIL_ERROR: 'Show error message
MsgBox "An error occured during sending the email. The email was not sent: " & vbNewLine & Err.Description, vbCritical, "Error " & Err.Number, Err.HelpFile, Err.HelpContext
End Function
And a procedure SendMultipleEmails looping through a worksheet and run SendMyEMail for every row.
Public Sub SendMultipleEmails()
Dim wsMail As Worksheet
Set wsMail = Worksheets("MyMailSheet")
Dim iRow As Long, lRow As Long
lRow = wsMail.Cells(wsMail.Rows.Count, "A").End(xlUp).Row 'find last used row in column A
For iRow = 1 To lRow 'run from first to last used row
SendMyEMail wsMail.Cells(i, "A"), wsMail.Cells(i, "B"), wsMail.Cells(i, "C"), wsMail.Cells(i, "D")
'SendMyEMail for every row in that sheet where MailTo is in column A, MailCC is in column B, …
Next iRow
End Sub
You can check if the file exists before attempting to draft the email.
Sub SendEmail()
'Exit if file does not exist
If Len(Dir("E:\Auto Reports\test.xlsb", vbDirectory)) = 0 Then Exit Sub
'Proceed
Dim OutApp As Object
'rest of code
End Sub

Create Email and Attach Selected Email

I create a new email with the code below.
I'd like to have an attachment. I think I have to use an OutMail.Attachment.Method but the attachment needs to be a specific email.
I want the entire email with contents (ie. texts, files, pics, etc.) as the attachment.
I'd like to attach whatever email I have highlighted (as an .msg).
Public Sub RemarkRequest()
Dim OutApp As Object
Dim OutMail As Object
Dim Signature As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
'Get the user signature
With OutMail
.Display
End With
Signature = OutMail.HTMLBody
'Change the mail address and subject in the macro before you run it.
With OutMail
.To = "yyy#bbb.com; zzz#bbb.com"
.CC = ""
.BCC = ""
.Subject = "Subject"
.HTMLBody = "Text" & Signature
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Example will be -
'// Forces explicit declaration of all variables in a file
Option Explicit
Sub ForwardAsAttchment()
'// Declare variables
Dim olMsg As Outlook.MailItem
Dim olItem As Outlook.MailItem
Dim olSignature As String
On Error Resume Next
If Application.ActiveExplorer.Selection.Count = 0 Then
MsgBox ("No Item selected")
Exit Sub
End If
For Each olItem In Application.ActiveExplorer.Selection
Set olMsg = Application.CreateItem(olMailItem)
'// Get the user signature
With olMsg
.Display
End With
olSignature = olMsg.HTMLBody
'// Change the mail address and subject in the macro before you run it.
With olMsg
.Attachments.Add olItem, olEmbeddeditem ' Attch Selected email
.Subject = "Subject"
.To = "yyy#bbb.com; zzz#bbb.com"
.CC = ""
.BCC = ""
.HTMLBody = "Text" & olSignature
.Display
' .Send
End With
Next
'// Clean up
Set olItem = Nothing
Set olMsg = Nothing
End Sub