I am trying to send mails automatically with an outlook template making minor changes to the text linked to the excel file. But the results do not appear when I choose an HTML format. Here is my code: I think the problem is with the .HTMLbody line because everything else in the code works fine. Could someone help?
Sub Test1()
'Working in Office 2000-2016
Dim OutApp As Outlook.Application
Dim OutMail As Outlook.MailItem
Dim cell As Range
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItemFromTemplate("C:\Users\600008809\Desktop\Reminder emails\Initial Survey.oft")
On Error GoTo cleanup
For Each cell In Columns("G").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*#?*.?*" And _
LCase(Cells(cell.Row, "H").Value) = "yes" _
And LCase(Cells(cell.Row, "I").Value) <> "send" Then
'Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = cell.Value
.Subject = "abc!"
.BodyFormat = olFormatHTML
.HTMLBody = Replace(.HTMLBody, "<< HiringManager >>", Worksheets("Tool").Range(4, 2))
'You can add files also like this
'.Attachments.Add ("C:\test.txt")
Set .SendUsingAccount = OutApp.Session.Accounts.Item("abc#xyz.com")
.Send
'.Display 'Or use Display
End With
On Error GoTo 0
Cells(cell.Row, "I").Value = "send"
Set OutMail = Nothing
End If
Next cell
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub
This line is not good:
.HTMLBody = Replace(.HTMLBody, "<< HiringManager >>", Worksheets("Tool").Range(4, 2)
You have to replace the range value, or cell value in here so you should use
.HTMLBody = Replace(.HTMLBody, "<< HiringManager >>", Worksheets("Tool").cells(4, 2).value
Related
I'm working on a way to send emails to a list of recipients. All emails should contain the same body, but with unique attachments. The code I'm using successfully retrieves the addresses from column N, and inserts attachments based on paths in corresponding rows in columns O:AZ.
The issue I'm encountering is that the first email created using the code has no body. The recipient and attachments are correct, but the email itself is empty. All other emails created show the body correctly. I have very little experience with VBA, and cannot find what's causing the issue.
Any help regarding the code and possible issues would be appreciated! Please let me know if you need more details regarding the code or data.
Sub create_emails()
Dim OutApp As Object
Dim OutMail As Object
Dim sh As Worksheet
Dim cell As Range
Dim FileCell As Range
Dim rng As Range
Dim strobody As String
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set sh = Sheets("Sheet2")
Set OutApp = CreateObject("Outlook.Application")
For Each cell In sh.Columns("N").Cells.SpecialCells(xlCellTypeConstants) 'email addresses located in Sheet2, column N
Set rng = sh.Cells(cell.Row, 1).Range("O1:AZ1") 'File paths stored in corresponding rows, columns 0:AZ
If cell.Value Like "?*#?*.?*" And _
Application.WorksheetFunction.CountA(rng) > 0 Then
Set OutMail = OutApp.CreateItem(0)
With OutMail
.SentOnBehalfOfName = "xxx#xxx.xxx"
.To = cell.Value
.Subject = "test subject"
.Body = strbody
strbody = "Test text"
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
.Display 'Or use .Display / .Send
End With
Set OutMail = Nothing
End If
Next cell
Set OutApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
You're setting strbody after you're using it, so the first time it's used it's empty.
Change:
With OutMail
.SentOnBehalfOfName = "xxx#xxx.xxx"
.To = cell.Value
.Subject = "test subject"
.Body = strbody
strbody = "Test text"
To:
With OutMail
.SentOnBehalfOfName = "xxx#xxx.xxx"
.To = cell.Value
.Subject = "test subject"
strbody = "Test text"
.Body = strbody
And also, if you had Option Explicit set, you'd notice that your declaration for strbody is mistyped to strobody.
please help me fix this. I'm new to this area and I would like to paste multiple set of range from excel and paste it onto an outlook email with modified size. Please help me. Thanks in advance!
Here's my current code:
Sub EmailSend()
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim StrBody As String
StrBody = "Please see our current Report"
Set rng = Nothing
On Error Resume Next
'Only the visible cells in the selection
'Set rng = Selection.SpecialCells(xlCellTypeVisible)
'You can also use a fixed range if you want
Set rng = Range("C4:D8").SpecialCells(xlCellTypeVisible)
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)
On Error Resume Next
With OutMail
.To = "x"
.CC = "x"
.BCC = "x"
.Subject = "RRF for Vendor Sourcing - " & Cells(3, 2)
.HTMLBody = StrBody & RangetoHTML(rng)
.Display 'or use .Display
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
This line of code is what defines your range.
Set rng = Range("C4:D8").SpecialCells(xlCellTypeVisible)
You can simply define another range :
Dim rng2 As Range
Set rng2 = Range("J4:N8").SpecialCells(xlCellTypeVisible)
and then make another call to RangetoHTML() using that second range:
RangetoHTML(rng2)
which will return another string of html which you can then concatenate like this:
.HTMLBody = StrBody & RangetoHTML(rng) & "<br>" & RangetoHTML(rng2)
I am trying to add Excel data to Outlook email.
This is an illustration of the output in an Outlook email editor. The img I'm trying to add should be add at the end, after the Excel content.
I tried various ways to add an image which is a footnote.
I tried adding the <img> tag to attach it as HTML attachment but it gets attached without any spacing.
Tried using these two lines initially
.Attachments.Add "C:\Users\Sumit Jain\Pictures\11\city.jpg", olByValue, 0
.HTMLBody = .HTMLBody & "<img src='cid:city.jpg'><br>"
Then I tried making a default signature in Outlook.
The code
.HTMLBody = "<HTML><body><body></HTML>" & .HTMLBody
appends Outlook's default signature on the top and then the Excel content after.
Reference to page I used the logic from Link
Below is the code
Private Sub CommandButton9_Click()
On Error GoTo ERRORMSG
Dim OutApp As Object
Dim OutMail As Object
Dim olInsp As Object
Dim wdDoc As Object
Dim oRng As Object
Set otlApp = CreateObject("Outlook.Application")
Set olMail = otlApp.CreateItem(olMailItem)
Set Doc = olMail.GetInspector.WordEditor
Set mainWB = ActiveWorkbook
mainWB.Sheets("Mail").Range("m8").Value = ComboBox4.Value
mainWB.Sheets("Mail").Range("n8").Value = TextBox40.Value
mainWB.Sheets("Mail").Range("q8").Value = ComboBox5.Value
mainWB.Sheets("Mail").Range("r8").Value = ComboBox6.Value
mainWB.Sheets("Mail").Range("s8").Value = ComboBox7.Value
mainWB.Sheets("Mail").Range("t8").Value = TextBox44.Value
On Error Resume Next
Set OutApp = GetObject(, "Outlook.Application")
If Err <> 0 Then Set OutApp = CreateObject("Outlook.Application")
On Error GoTo 0
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = mainWB.Sheets("Email").Range("A3").Value
.cc = mainWB.Sheets("Mail").Range("L12").Value
.Subject = mainWB.Sheets("Mail").Range("O15").Value
Set olInsp = .GetInspector
Set wdDoc = olInsp.WordEditor
Set oRng = wdDoc.Range
'force html format
.HTMLBody = "<HTML><body><body></HTML>" & .HTMLBody
.Display
'--- start with 6 CrLf's, so we can place each table
' above all but the last used...
oRng.InsertAfter vbCrLf & vbCrLf
'--- now reselect the entire document, collapse our cursor to the end
' and back up one character (so that the table inserts before the SIXTH CrLf)
Set oRng = wdDoc.Range
oRng.collapse 0
oRng.Move 1, -1
Range("K3:T10").Select
Selection.Copy
oRng.Paste
'--- finally move the cursor all the way to the end and paste the
' second table BELOW the SIXTH CrLf
Set oRng = wdDoc.Range
oRng.collapse 0
Range("K38:T46").Select
Selection.Copy
oRng.Paste
End With
Exit Sub
End Sub
Try the following in your code....
You need to add Mysig.htm to the name of your signature
SigString = Environ("appdata") & "\Microsoft\Signatures\" & UOutLookSign & ".htm"
If Dir(SigString) <> "" Then
Signature = GetBoiler(SigString)
Else
Signature = ""
End If
I'm having problems with a macro. It used to work on the 2013 version of outlook and excel but for some reason the CC function has stopped working and I keep getting errors.
With the 2013 version I used the following code to define the CC and BCC:
Set sh = Sheets ("Sheet1")
.to = cell.Value
.CC = sh.Cells(cell.Row, 1).Range("C1:C1")
.BCC = sh.Cells(cell.Row, 1).Range("D1:D1")
This however doesn't work in the 2016 version of my excel and outlook. Every single row in excel need to have its own To , CC and BCC selected from a row in Excel. For some reason it keeps saying CC is not a valid method. object_Mailitem failed.
Editing the variables behind the .cc and .bcc to "mail#x.com" is working without getting the error. So I assume there is something wrong with the line after the .cc, i've tried multiple solutions which ended up in either the same error or an other error telling me it doesn't recognize the .Send command.
EDIT: added the full code of the macro
Sub Send files()
Dim OutApp As Object
Dim OutMail As Object
Dim sh As Worksheet
Dim cell As Range
Dim FileCell As Range
Dim rng As Range
Dim ccontvangen 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)
Set rng = sh.Cells(cell.Row, 1).Range("E1:Z1")
If cell.Value Like "?*#?*.?*" And _
Application.WorksheetFunction.CountA(rng) > 0 Then
Set OutMail = OutApp.CreateItem(0)
With OutMail
.to = cell.Value
.cc = "x"
.Subject = "Subject"
.Attachments.Add "G:\signature.png", olByValue, 0
.Body = " "
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
End With
Set OutMail = Nothing
End If
Next cell
Set OutApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
I had encountered a similar issue where the Subject Line, To, and Cc were not being listed completely.
I figured out the problem by adding a & ";" to the end of each field.
I am attempting to write a macro to read a spreadsheet. Whenever someone is one year or later with a task, it will send their supervisor email.
I figured out how to send one email per person to a supervisor, but I wonder if I can scan all people and add them to one email. I tried to modify it, but I could not get it (this is my second day of VBA, hehe)
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("D").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*#?*.?*" And _
LCase(Cells(cell.Row, "E").Value) = "yes" _
And LCase(Cells(cell.Row, "H").Value) <> "send" Then
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = cell.Value
.Subject = "Reminder"
If Cells(cell.Row, "E").Value = "YES" Then
.body = Cells(cell.Row, "B") & " " & Cells(cell.Row, "A")
.Send
On Error GoTo 0
Cells(cell.Row, "H").Value = "send"
Set OutMail = Nothing
End If
Next cell
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub
This is untested, but let me know how it works:
Sub test()
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Dim bodyText As String 'this is new
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
bodyText = ""
On Error GoTo cleanup
For Each cell In Columns("D").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*#?*.?*" And LCase(Cells(cell.row, "E").Value) = "yes" And LCase(Cells(cell.row, "H").Value) <> "send" Then
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = cell.Value
.Subject = "Reminder"
If Cells(cell.row, "E").Value = "YES" Then
'The next line should add the text, and a new line character, so the next cell that needs this will simply be added to the string
bodyText = Cells(cell.row, "B") & " " & Cells(cell.row, "A") & vbCrLf
End If
End With
On Error GoTo 0
Cells(cell.row, "H").Value = "send"
Set OutMail = Nothing
End If
Next cell
OutMail.body = bodyText
OutMail.Send
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub