I have this code which uses an Excel sheet to create Outlook emails with attachments. It creates the emails correctly and Display works fine, but I cannot get SendUsingAccount to send the emails (manual sending of each email after Display works fine).
Could someone please point out the error?
Many thanks!
Sub Send_Files()
Dim Sht As Worksheet
Dim olApp As Object, olMail As Object, olRecip As Object, olAtmt As Object
Dim iRow As Long
Dim Recip As String, Subject As String, Atmt As String
Dim OutApp As Outlook.Application
Dim OutMail As Outlook.MailItem
Dim OutAccount As Outlook.Account
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(olMailItem)
Set OutAccount = OutApp.Session.Accounts.Item(2)
Application.EnableEvents = False
Application.ScreenUpdating = False
iRow = 2
Set olApp = CreateObject("Outlook.Application")
Set Sht = ThisWorkbook.Worksheets("Mailinglist_1")
Do Until IsEmpty(Sht.Cells(iRow, 1))
Recip = Sht.Cells(iRow, 2).Value
Subject = Sht.Cells(iRow, 4).Value
Atmt = Sht.Cells(iRow, 3).Value
Set olMail = olApp.CreateItem(0)
With olMail
Set olRecip = .Recipients.Add(Recip)
Set olMail.SendUsingAccount = OutAccount
.Subject = "Test 2021"
.Body = "Dear " & Sht.Cells(iRow, 1).Value & "," & vbNewLine & vbNewLine & _
"Text" & vbNewLine & _
"Text" & vbNewLine & _
"The Team"
olRecip.Resolve
Set olAtmt = .Attachments.Add(Atmt)
Set .SendUsingAccount = OutAccount
.Send
End With
iRow = iRow + 1
Loop
Set olApp = Nothing
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Related
I have a script that searches a group inbox subfolder and replies to the first email with a matching subject. It then replies to all. When I populate the email I cannot add my text to the rest of the email. Only either or.
I've seen many responses to similar problems that show .HTMLBody = "test" & .HTMLBody as a solution but when the debug reaches this line, the second .HTMLBody is shown as 'application-defined or object-defined error'.
Any insight into whats causing the problem or where else I can get the info from previous emails in the chain to input it that way would be greatly appreciated.
Thanks,
Sub Find_Email()
Dim olMail As Outlook.MailItem
Dim olReply As Outlook.MailItem
Dim olItems As Outlook.Items
Dim olNS As Namespace
Dim olMailbox As Folder
Dim olFolder As Folder
Dim subFolder As Folder
Dim BodyText As String
Set olNS = GetNamespace("MAPI")
Set olMailbox = olNS.Folders("Group_Inbox")
Set olFolder = olMailbox.Folders("test_Folder")
Set subFolder = olFolder.Folders("test_subFolder")
Set olItems = subFolder.Items
TheDate = Format(Date, "DD-MM-YYYY")
TheDate1 = Format(Date, "YYYY-MM")
TheDate2 = Format(Date, "YYYYMMDD")
TheDate3 = Format(Date, "YYYY")
'Find most recent email and populate
olItems.Sort "ReceivedTime", True
For i = 1 To olItems.Count
Set olMail = olItems(i)
If InStr(olMail.Subject, "Desired_Subject " & TheDate) > 0 Then
Set olReply = olMail.ReplyAll
With olReply
.Display
.To = "Recipients#gmail.com"
.CC = ""
.Subject = "Test_Subject"
'.Attachments.Add "Document_destination"
.BodyFormat = olFormatHTML
.HTMLBody = "This is a test email sending in Excel" & .HTMLBody ' This is the problem line.
Exit Sub
End With
End If
Next i
End Sub
'I understand that it might be the fact it is in a group inbox, which means that it could work for you but 'still may not work for me.
'Thanks again,
Try this (i can't test it, just a thought )
'Somewehere declare this string variable
Dim incomingHTMLBody as string
olItems.Sort "ReceivedTime", True
For i = 1 To olItems.Count
Set olMail = olItems(i)
If InStr(olMail.Subject, "Desired_Subject " & TheDate) > 0 Then
incomingHTMLBody = olMail.HTMLBody
Set olReply = olMail.ReplyAll
With olReply
.Display
.To = "Recipients#gmail.com"
.CC = ""
.Subject = "Test_Subject"
'.Attachments.Add "Document_destination"
.BodyFormat = olFormatHTML
.HTMLBody = "This is a test email sending in Excel" & incomingHTMLBody
Exit Sub
End With
End If
Next i
End Sub
You may need a bit more care referencing Outlook objects in your environment.
Option Explicit ' Consider this mandatory
' Tools | Options | Editor tab
' Require Variable Declaration
' If desperate declare as Variant
Sub Find_Email()
Dim objApp As Outlook.Application
Set objApp = CreateObject("outlook.application")
Dim objNS As Namespace
Set objNS = objApp.GetNamespace("MAPI")
Dim objMailbox As Outlook.Folder
Set objMailbox = objNS.Folders("Group_Inbox")
Dim objFolder As Outlook.Folder
Set objFolder = objMailbox.Folders("test_Folder")
Dim subFolder As Outlook.Folder
Set subFolder = objFolder.Folders("test_subFolder")
Dim objItems As Outlook.Items
Set objItems = subFolder.Items
Dim TheDate As Date
TheDate = Format(Date, "DD-MM-YYYY")
'Find most recent email and populate
objItems.Sort "ReceivedTime", True
Dim i As Long
Dim objMail As Outlook.MailItem ' olMail is not a good variable name
Dim objReply As Outlook.MailItem
Debug.Print objItems.Count
For i = 1 To objItems.Count
Debug.Print objItems(i).Subject
If objItems(i).Class = olMail Then ' verify item is a mailitem
Set objMail = objItems(i)
If InStr(objMail.Subject, "Desired_Subject " & TheDate) > 0 Then
Set objReply = objMail.ReplyAll
With objReply
.Display
.To = "Recipients#gmail.com"
.CC = ""
.Subject = "Test_Subject"
'.Attachments.Add "Document_destination"
.BodyFormat = olFormatHTML
Debug.Print .htmlbody ' verify property is available
.htmlbody = "This is a test email sending in Excel" & .htmlbody ' This is the problem line.
Exit For
End With
End If
End If
Next i
End Sub
The VBA code below sends email with a specific range in body.
Despite selecting only visible cells, I receive all cells.
It seems SpecialCells(xlCellTypeVisible).Select does not work.
Sub VBA_AUTO_MAIL()
Dim sh As Worksheet
Set sh = ThisWorkbook.Sheets("Arkusz1")
Dim lr As Integer
lr = sh.Range("A" & Application.Rows.Count).End(xlUp).Row
sh.Range("A1:H" & lr).SpecialCells(xlCellTypeVisible).Select
ThisWorkbook.EnvelopeVisible = True
With Selection.Parent.MailEnvelope.Item
.to = sh.Range("L6").Value
.cc = sh.Range("L8").Value
.Subject = sh.Range("L9").Value
.attachments.Add "C:\Users\test\Desktop\TEST VBA\TEST_VBA.txt"
.send
End With
End Sub
I expect only visible columns in email body but I receive all columns.
Try the following
Option Explicit
Sub VBA_AUTO_MAIL()
Dim sh As Worksheet
Set sh = ThisWorkbook.Sheets("Arkusz1")
Dim lr As Long
lr = sh.Range("A" & Application.Rows.Count).End(xlUp).Row
Dim rng As Range
Set rng = sh.Range("A1:H" & lr).SpecialCells(xlCellTypeVisible)
rng.Copy
Dim olApp As Object
Set olApp = CreateObject("Outlook.Application")
Dim Email As Object
Set Email = olApp.CreateItem(0)
Dim wdDoc As Word.Document
Set wdDoc = Email.GetInspector.WordEditor
With Email
.To = sh.Range("L6").Value
.CC = sh.Range("L8").Value
.BCC = ""
.Subject = sh.Range("L9").Value
'.Attachments.Add "C:\Users\test\Desktop\TEST VBA\TEST_VBA.txt"
.Display
wdDoc.Range.PasteAndFormat Type:=wdChartPicture
.Send
End With
End Sub
Make sure to Reference Microsoft Word xx.x Object Library
https://stackoverflow.com/a/42662697/4539709
Tried all other codes on similar pages but failed to work.
This is my current version. Works only if I currently have a new email window open and oddly, my code will paste the .body and cell range details into 2 separate new email windows.
I just want the code to open a new email window with contents .body and cell range details (contains chart). Anybody have any ideas where my code went wrong?
Sub pasting01()
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.TO = "xyz#anc.com"
.CC = "abc#xyz.com"
.Subject = "Test"
.Body = "Dear Mr Lee" & vbNewLine
ActiveSheet.Range("A1:J30").Copy
Set vInspector = OutMail.GetInspector
Set wEditor = vInspector.WordEditor
wEditor.Application.Selection.Start = Len(.Body)
wEditor.Application.Selection.End = wEditor.Application.Selection.Start
wEditor.Application.Selection.Paste
.display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
You have some errors on your code, try using Option Explicit top of your module
Option Explicit
Public Sub pasting01()
Dim Sht As Excel.Worksheet
Set Sht = ThisWorkbook.ActiveSheet
Dim rng As Range
Set rng = Sht.Range("A1:J30")
rng.Copy
Dim OutApp As Object
Set OutApp = CreateObject("Outlook.Application")
Dim OutMail As Object
Set OutMail = OutApp.CreateItem(0)
Dim vInspector As Object
Set vInspector = OutMail.GetInspector
Dim wEditor As Object
Set wEditor = vInspector.WordEditor
With OutMail
.TO = "xyz#anc.com"
.CC = "abc#xyz.com"
.Subject = "Test"
.display
wEditor.Paragraphs(1).Range.Text = "Dear Mr Lee" & vbCr
wEditor.Paragraphs(2).Range.Paste
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Can you mess about with the following to suit your purpose?
Option Explicit
Sub pasting01()
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
Dim myChart As Chart
Set myChart = ThisWorkbook.Worksheets("Sheet1").ChartObjects("Chart 1").Chart
Dim myPicture As String
Dim fileName As String
Dim myPath As String
myPicture = "Chart1.png"
myPath = "C:\Users\User\Desktop\"
fileName = myPath & myPicture
myChart.Export fileName
With OutMail
.TO = "xyz#anc.com"
.CC = "abc#xyz.com"
.Subject = "Test"
.Body = "Dear Mr Lee" & vbNewLine
.Attachments.Add fileName
.HTMLBody = "<html><p>First Line... </p>" & _
"<img src=cid:" & Replace(myPicture, " ", "%20") & " height=2*240 width=2*180>" & _
"<p>Salutation</p>" & _
"<p>" & "More text" & "</p></html>"
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
Kill fileName
End Sub
Result:
I would like to copy a range from protected Excel sheet and paste it into Outlook as a picture.
My code is pasting the text then the picture, but at the same time deleting the text.
How can I paste the picture under the text.
Sub Send_Email()
Dim r As Range
Set r = Range("NR7:OD39")
Dim outlookApp As Outlook.Application
Set outlookApp = CreateObject("Outlook.Application")
Dim OutMail As Outlook.MailItem
Set OutMail = outlookApp.CreateItem(olMailItem)
Dim StrFileName As String
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Sheets("table1").Select
ActiveSheet.Unprotect Password:="blabla"
ActiveSheet.Outline.ShowLevels RowLevels:=8, ColumnLevels:=8
r.Select
r.Copy
OutMail.Display
Dim Email As Word.Document
Set Email = OutMail.GetInspector.WordEditor
With OutMail
.To = "Name.surname#amazon.com"
.CC = "Surname.Name#amazon.com"
.Subject = "Subject"
.Body = "Hi everybody," & vbNewLine & "actual Status"
.Display
End With
Email.Range.PasteAndFormat wdChartPicture
ActiveSheet.Outline.ShowLevels RowLevels:=1, ColumnLevels:=1
ActiveSheet.Protect Password:="blabla"
End Sub
Starting with this line
Set Email = OutMail.GetInspector.WordEditor
this should do it:
Dim ran as Word.Range
Set Email = OutMail.GetInspector.WordEditor
With OutMail
.To = "Name.surname#amazon.com"
.cc = "Surname.Name#amazon.com"
.Subject = "Subject"
.Body = "Hi everybody," & vbNewLine & "actual Status"
.Display
End With
Email.Range.InsertAfter vbCrLf
Set ran = Email.Range(Email.Content.End - 1, Email.Content.End - 1)
ran.PasteAndFormat wdChartPicture
I have a folder with 50 files and I have a list of 50 email addresses. Each file goes to a different email address. Is there a way to write a macro that performs this task?
The problem with the set of code below is two-fold:
1) I have 3 COLUMNS of data in an Excel file: One for subject, one for email address to send to, and the third for the FILE PATH of where the attachment to be attached is stored.
The code below does not allow for a pre-determined set of subject arguments. It also uses ROWS?? for the filepath field instead of a column like it does for send to? So confusing.
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
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
Here is quick example, assuming col A = Email, Col B = Subject & Col C = Path
Option Explicit
Public Sub Example()
Dim olApp As Object
Dim olMail As Object
Dim olRecip As Object
Dim olAtmt As Object
Dim iRow As Long
Dim Recip As String
Dim Subject As String
Dim Atmt As String
iRow = 2
Set olApp = CreateObject("Outlook.Application")
Dim Sht As Worksheet
Set Sht = ThisWorkbook.Worksheets("Sheet1")
Do Until IsEmpty(Sht.Cells(iRow, 1))
Recip = Sht.Cells(iRow, 1).Value
Subject = Sht.Cells(iRow, 2).Value
Atmt = Sht.Cells(iRow, 3).Value ' Attachment Path
Set olMail = olApp.CreateItem(0)
With olMail
Set olRecip = .Recipients.Add(Recip)
.Subject = Subject
.Body = "Hi "
.Display
Set olAtmt = .Attachments.Add(Atmt)
olRecip.Resolve
End With
iRow = iRow + 1
Loop
Set olApp = Nothing
End Sub