I have this code that I can use to send out e-mails with vba in Excel.
Using .body instead of .Inspector.WordEditor I can type exactly what I want to be in the e-mail, but I want the text of the e-mail to be a Word document with some pictures in it and stuff.
How would I go about that? I cannot get .Inspector.WordEditor to work the way that I want it to. (To be honest it does not work at all for me)
Sub Test1()
Dim networkstatus As Boolean
If InternetGetConnectedState(0&, 0&) Then
networkstatus = True
Else
networkstatus = False
End If
If Not networkstatus = True Then
Exit Sub
End If
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("B").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*#?*.?*" And _
LCase(Cells(cell.Row, "C").Value) = "yes" Then
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = cell.Value
.Subject = "Test"
.Inspector.WordEditor ("C:\test.docx")
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
End If
Next cell
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub
Edit: I am aware that you can use HTMLBody, but I do not count on my colleagues to use that.
Send it as an attachment instead
.Attachments.Add("C:\test.docx")
Related
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
I have been assigned to send out Christmas greetings that have been customized to specific customers. However, these greetings are in the 100's and doing it automatically would save me hours - and these greetings are done every year!
In Excel, the customer names are listed in column A, the individual emails in column B, and the path to the individual customized greeting file in column C.
What I have currently found is a VBA code that offers me the option to attach (but not embed) these files through their paths to the individual emails.
Might anyone explain to me and/or demonstrate how to embed the attached files that are found through column C ?
Thank you very much!
What I have now is the following:
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 = "Merry Christmas!"
.Body = "Merry Christmas!"
For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
If Trim(FileCell) <> "" Then
If Dir(FileCell.Value) <> "" Then
.Attachments.Add FileCell.Value, olByValue, 0
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 could do using HTML email, something like
Set o = Application.CreateItem(olMailItem)
o.BodyFormat = olFormatHTML
o.HTMLBody = "<img src='C:\Users\Pictures\a1.png'>"
o.Display
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 trying to use the standard code to email a workbook to multiple recipients but build in some error handling that is likely to arise in my model.
If the email address is not available the cell where the email address would be found would read "Pending Search...".
If that is the case the loop simply needs to skip that cell and move on the the next email address.
Below is my code. The issue is coming from the IF/Then/Next line. I am getting a Next without For error. Any input would be greatly appreciated.
Sub Mail_workbook_Outlook_1()
Dim OutApp As Object
Dim OutMail As Object
Dim Position_In_Loop As Long
Dim Total_Emails As Long
Dim Email_Address As String
Dim Dashboard As Worksheet
Set Dashboard = ActiveWorkbook.Worksheets("Dashboard")
Dim Body As Range
Set Body = Dashboard.Range("F13")
Dim Attachment As Range
Set Attachment = Dashboard.Range("F24")
With Dashboard
Total_Emails = Dashboard.Range("G3")
End With
For Position_In_Loop = 1 To Total_Emails
Email_Address = Dashboard.Range("C3").Offset(Position_In_Loop, 0)
If Email_Address = "Pending Search..." Then Next Position_In_Loop
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = "Email_Address"
.CC = ""
.BCC = ""
.Subject = "Open Job Violations"
.Body = "Body"
.Attachments.Add (Attachment)
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
Next Position_In_Loop
End Sub
You shouldn't increment the loop like that. You are going to skip emails. Wrap the whole the Outlook mail code in an If statement.
Option Explicit
Sub Mail_workbook_Outlook_1()
Dim OutApp As Object
Dim OutMail As Object
Dim Position_In_Loop As Long
Dim Total_Emails As Long
Dim Email_Address As String
Dim Dashboard As Worksheet
Set Dashboard = ActiveWorkbook.Worksheets("Dashboard")
Dim Body As Range
Set Body = Dashboard.Range("F13")
Dim Attachment As Range
Set Attachment = Dashboard.Range("F24")
With Dashboard
Total_Emails = Dashboard.Range("G3")
End With
For Position_In_Loop = 1 To Total_Emails
Email_Address = Dashboard.Range("C3").Offset(Position_In_Loop, 0)
If Email_Address <> "Pending Search..." Then
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = "Email_Address"
.CC = ""
.BCC = ""
.Subject = "Open Job Violations"
.Body = "Body"
.Attachments.Add Attachment
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End If
Next Position_In_Loop
End Sub
change this line
If Email_Address = "Pending Search..." Then Next Position_In_Loop
to
If Email_Address = "Pending Search..." Then
Position_In_Loop=Position_In_Loop+1
end if
I use Excel to send monthly statements to our brokers. Is there a way to add a column to show if each of the individual email is actually sent.
Some of the rows might have an invalid email address and the only way I can tell if all of them are sent is by going through my sent folder.
Sub SendEmails()
Dim answer As Variant
answer = MsgBox("You are about to send the statements. Proceed?", vbYesNo + vbQuestion, "Alert")
Select Case answer
Case vbYes
MsgBox "Process may take a while to finish. Do not attempt to close the worksheet or Outlook.", vbInformation, "Alert"
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("Listing")
Set OutApp = CreateObject("Outlook.Application")
For Each cell In sh.Columns("D").Cells.SpecialCells(xlCellTypeConstants)
Set rng = sh.Cells(cell.Row, 1).Range("A1:B1")
If cell.Value Like "?*#?*.?*" And _
Application.WorksheetFunction.CountA(rng) > 0 Then
Set OutMail = OutApp.CreateItem(0)
With OutMail
.to = cell.Value
.Subject = "Statement of Account - " & cell.Offset(0, 2).Value
.Body = 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
Case vbNo
GoTo Quit:
End Select
Quit:
End Sub
Why not just Resolve each Recipient's email before sending
eg:
For Each olRecip In .Recipients
olRecip.Resolve
If Not olRecip.Resolve Then
olMsg.Display
End If