I'm trying to automate a report by being able to send a selected range of cells, that includes hidden cells, by making a macro. When I try to run the macro, it is blank. Please note that the text not written as a code are instructions. Macro is shown below:
Sub SendforApproval()
'
' SendforApproval Macro
'
' Generate Email
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Dim rng As Range
If ActiveWorkbook.Path <> "" Then
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
Set myOlApp = CreateObject("Outlook.Application")
'This is where the body of the email is populated - you can point to cells in your worksheet to pull text from them
strbody = "<font size=""3"" face=""Cambria"">" & _
"Hi " & Range("B5") & ",<br>" & _
"<br>Please note finance request #" & Range("a7") & " has been accepted. Upon review, please use voting buttons to Approve or Send for Rework.<br>"
' The range belows designates which portion of your sheet will be inserted in the body of the email
Set rng = Sheets("SheetName").Range("A7:T22").SpecialCells(xlCellTypeVisible)
'You can also use a fixed range if you want or flex range
'Set rng = Sheets("YourSheet").Range("D4:D12").SpecialCells(xlCellTypeVisible)
'Set rng = Range("f7").Resize(Application.CountA(Range("f7:f" & Rows.Count)), 12)
On Error GoTo 0
If rng Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected" & _
vbNewLine & "please correct and try again.", vbOKOnly
Exit Sub
End If
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
' This section defines receipants, Subject
On Error Resume Next
With OutMail
.To = Range("D7")
.CC = "yourname#email.com"
.BCC = ""
.Subject = "Finance Request #" & Range("a7")
' This section adds Voting buttons
.Display 'or use .Send to automatically send without giving opportunity to review final product
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
' End of email process
End If
End Sub
you should use "on error resume next" with more caution. You dont see the exception that occurs.
your failure is that you want to get the value of the cells D7 and A7 (string) but you take instead the range (object).
Try the following:
With OutMail
.To = Range("D7").Value
.CC = "yourname#email.com"
.BCC = ""
.Subject = "Finance Request #" & Range("A7").Value
' This section adds Voting buttons
.Display 'or use .Send to automatically send without giving opportunity to review final product
End With
Related
please click to view screenshot How do I copy details on each row with the table header and send the copied data to the email address on that row?
I've tried multiple ways to resolve this but can't find a solution:
Basically, I just need to copy what is on a row, send the copied values to the email address on that row.
Here's my code:
Sub AutoSendMail()
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
On Error GoTo cleanup
For Each cell In Columns("E").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*#?*.?*" And _
LCase(Cells(cell.Row, "F").Value) = "yes" Then
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = cell.Value
.Subject = "VBA TEST"
.Body = "Dear " & Cells(cell.Row, "A").Value _
& vbNewLine & vbNewLine & _
"Hello, this is a vba test, please ignore. " & _
"Thank you!"
'You can add files also like this
'.Attachments.Add ("C:\test.txt")
.Display 'Or use Display
End With
On Error GoTo 0
Cells(cell.Row, "G").Value = "SENT"
Set OutMail = Nothing
End If
Next cell
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub
I would like to use excel to send an email to the email address in column C from C5-C42 when the corresponding cell in column F contains the text "expired". I've been at this for over four days. I appreciate any help I can get.
I also keep getting a run-time error 424.
Below is my code:
Private Sub CommandButton1_Click()
If Target.Cells.Count > 1 Then Exit Sub
If Not Application.Intersect(Range("F5:F42"), Target) Is Nothing Then
If IsNumeric(Target.Value) And Target.Value = "Expired" Then
Call Mail_small_Text_Outlook
End If
End If
End Sub
Sub Mail_small_Text_Outlook()
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strbody = "Hi there" & vbNewLine & vbNewLine & _
"Your certification has expired." & vbNewLine & _
"Please contact an admin."
On Error Resume Next
With OutMail
.To = "emailaddress#net.com"
.CC = ""
.BCC = ""
.Subject = "This is the Subject line"
.Body = strbody
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Try this:
Private Sub CommandButton1_Click()
Dim c As Range
For Each c In Range("F5:F42")
If c.Value2 = "Expired" Then Call Mail_small_Text_Outlook(c.Offset(0, -3).Value2)
Next c
End Sub
This first routine is triggered by the command button click. It cycles through each cell in range F5:F42. If the cell has "Expired" as a value, it calls the mail routine, and passes to it the value contained in column C (by using the F column address -3 columns)
Sub Mail_small_Text_Outlook(emailAddress 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 = "Hi there" & vbNewLine & vbNewLine & _
"Your certification has expired." & vbNewLine & _
"Please contact an admin."
On Error Resume Next
With OutMail
.To = emailAddress
.CC = ""
.BCC = ""
.Subject = "This is the Subject line"
.Body = strbody
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
The mail routine accepts an email address as a parameter and hopefully you'll notice it replaces the generic "email address.com" you had on the .To line
Please be aware that currently the code is creating a new instance of Outlook for every time it needs to send an e-mail, without closing it. I think you can quit Outlook simply with the line OutApp.Quit so try sticking that in at the end of the Mail_small_Text_Outlook routine
I am trying to send an email to the names listed in column A but I don't have their email addresses. the email addresses are in outlook contacts. I can get it to display their emails in column B but I don't want to do that. I want to look up the email address and append it to the "To" field in the email. How it looks now is that, it only appends the email address for the last person in column A to all the emails for the other people in Column A. as seen in the pic. all the people in the A column are getting the same email address for the last person in their To field.
Option Explicit
Sub GetAddressesAndSendEmail()
Sheet10.Select
Dim o, AddressList, AddressEntry
Dim ToField As String
Dim c As range, r As range, AddressName As String
Set o = CreateObject("Outlook.Application")
Set AddressList = o.Session.AddressLists("Contacts")
Set r = Sheet10.range("A1", range("A1").End(xlDown))
For Each c In r
AddressName = c.Value
For Each AddressEntry In AddressList.AddressEntries
If AddressEntry.Name = AddressName Then
'c.Offset(0, 1).Value = AddressEntry.Address
ToField = AddressEntry.Address
'MsgBox ToField
Exit For
End If
Next AddressEntry
Next c
Dim OutApp As Object
Dim OutMail As Object
Dim cell As range
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
On Error GoTo cleanup
For Each cell In Columns("A").Cells.SpecialCells(xlCellTypeConstants)
If LCase(Cells(cell.Row, "D").Value) <> "" Then
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = ToField
.Subject = "Reminder"
.Body = "Dear " & Cells(cell.Row, "A").Value _
& vbNewLine & vbNewLine & _
"Please contact us to discuss bringing " & _
"your account up to date"
.Attachments.Add ("C:\" & Cells(cell.Row, "D").Value & ".txt")
'.Send
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
End If
Next cell
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub
Never ever loop through all items in an address book container. If the name can be resolved to a contact, all you need to do is set the MailItem.To property - when the message is sent, Outlook will resolve the name to an address. If you want to do that before sending the message, or if you really want the email address, call Application.Session.CreateRecipient - it will return an instance of the Recipient object. Call Recipient.Resolve and read Recipient.Address property. If the name cannot be resolved (if it is not found or the name is ambiguous), Recipient.Resolve will raise an exception.
Create each mail before you overwrite ToField.
For Each AddressEntry In AddressList.AddressEntries
If AddressEntry.Name = AddressName Then
'c.Offset(0, 1).Value = AddressEntry.Address
ToField = AddressEntry.Address
'MsgBox ToField
Set OutMail = o.CreateItem(0)
With OutMail
.To = ToField
.Subject = "Reminder"
.Body = "Dear " & Cells(cell.Row, "A").Value _
& vbNewLine & vbNewLine & _
"Please contact us to discuss bringing " & _
"your account up to date"
.Attachments.Add ("C:\" & Cells(cell.Row, "D").Value & ".txt")
'.Send
.Display
End With
Set OutMail = Nothing
Exit For
End If
Next AddressEntry
Consider doing it this way.
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
https://www.rondebruin.nl/win/s1/outlook/amail6.htm
I'm trying to build a macro that grabs a selection of cells from an Excel spreadsheet, pastes the cells into a new outlook email, then changes the format of the cells.
Specifically I want to convert the table to text, then change the font to Arial size 10.
The code below does the above, but I haven't been able to figure out how to convert the table to text, then change the text font.
Can anyone help?
Sub Email_test()
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Set rng = Nothing
Set rng = Sheets("Master").Range("A1:B99").SpecialCells(xlCellTypeVisible)
If rng Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected. " & _
vbNewLine & "Please correct and try again.", vbOKOnly
Exit Sub
End If
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = "User#company.com"
.CC = ""
.BCC = ""
.Subject = "Cells as text "
.HTMLbody = RangetoHTML(rng)
' In place of the following statement, you can use ".Display" to
' display the e-mail message.
.Display
End With
End Sub
This will work for you, instead of HTMLbody use body also removed your range to html function
Sub Email_test()
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Set rng = Nothing
Set rng = Sheets("Master").Range("A1:B99").SpecialCells(xlCellTypeVisible)
If rng Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected. " & _
vbNewLine & "Please correct and try again.", vbOKOnly
Exit Sub
End If
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Dim v As Variant: v = rng.Value
Dim tempStr As String: tempStr = ""
For i = LBound(v, 1) To UBound(v, 1)
For j = LBound(v, 2) To UBound(v, 2)
If j = 2 Then
tempStr = tempStr & v(i, j) & vbCrLf
Else
tempStr = tempStr & v(i, j) & " "
End If
Next j
Next i
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = "User#company.com"
.CC = ""
.BCC = ""
.Subject = "Cells as text "
.body = tempStr
' In place of the following statement, you can use ".Display" to
' display the e-mail message.
.Display
End With
End Sub
Please mark as an answer if you are satisfied with reply
The Outlook object model provides three main ways for working item bodies:
Body - a string representing the clear-text body of the Outlook item.
HTMLBody - a string representing the HTML body of the specified item.
Word editor - the Microsoft Word Document Object Model of the message being displayed. The WordEditor property of the Inspector class returns an instance of the Document class from the Word object model which you can use to set up the message body.
You can read more about all these ways in the Chapter 17: Working with Item Bodies. It us up to you which way is to choose.
In excel I have the following code which sends out emails for every cell that contains an email address in column K.
This would work except for the header in the table isn't an email address, so it breaks the code. I tried to skip the header by specifying "if cell.value = CONTACT METHOD, which is the header name text, then go to Next cell"
but this causes a "Next without for" error.
Sub Mail_small_Text_Outlook()
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
'Working in Office 2000-2013
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
On Error GoTo cleanup
For Each cell In Columns("K").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "*#*" Then
finaladdress = cell.Value
Else
finaladdress = cell.Value & "#email.smsglobal.com"
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = finaladdress
.Subject = "Reminder"
.Body = "Dear " & Cells(cell.Row, "A").Value _
& vbNewLine & vbNewLine & _
"Please contact us to discuss bringing " & _
"your account up to date"
'You can add files also like this
'.Attachments.Add ("C:\test.txt")
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
End If
Next cell
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub
If your goal is to skip cell K1 in looping down column K then:
For Each cell In Columns("K2:K" & Rows.Count).Cells.SpecialCells(xlCellTypeConstants)
You can enclose the code within the FOR/EACH loop within a separate IF statement, as below:
Sub Mail_small_Text_Outlook()
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
'Working in Office 2000-2013
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
On Error GoTo cleanup
For Each cell In Columns("K").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value = "CONTACT METHOD" Then
'Do Nothing, or Enter code here
Else
If cell.Value Like "*#*" Then
finaladdress = cell.Value
Else
finaladdress = cell.Value & "#email.smsglobal.com"
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = finaladdress
.Subject = "Reminder"
.Body = "Dear " & Cells(cell.Row, "A").Value _
& vbNewLine & vbNewLine & _
"Please contact us to discuss bringing " & _
"your account up to date"
'You can add files also like this
'.Attachments.Add ("C:\test.txt")
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
End If
End If
Next cell
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub