I am trying to accomplish this:
I am trying to avoid using RangeToHtml if possible. It seems to copy the range but does not paste it in Outlook. Here is what I have thus far.
Sub Send_Email_Condition_Cell_Value_Change()
Dim pApp As Object
Dim pMail As Object
Dim pBody As String
Dim rng As Range
Set rng = Range("B6:C16")
Set pApp = CreateObject("Outlook.Application")
Set pMail = pApp.CreateItem(0)
On Error Resume Next
With pMail
.To = "#gmail.com"
.CC = ""
.BCC = ""
.Subject = "BLANK Account Action Price Notification"
.Body = "Hello, our recommended action price for BLANK has been hit." & vbNewLine & vbNewLine & _
"Thank you."
.Display
Dim wdDoc As Object '## Word.Document
Dim wdRange As Object '## Word.Range
Set wdDoc = OutMail.GetInspector.WordEditor
Set wdRange = wdDoc.Range(0, 0)
wdRange.InsertAfter vbCrLf & vbCrLf
'Copy the range in-place
rng.Copy
wdRange.Paste
'Below will auto send the email when apostrophe is removed
'.Send
End With
On Error GoTo 0
Set pMail = Nothing
Set pApp = Nothing
End Sub
I have tried utilizing RangeToHtml, but that is a bit complex for my abilities. I have found this solution however I am unable to make it work.
You are using the wrong object name
Change
Set wdDoc = OutMail.GetInspector.WordEditor
with
Set wdDoc = pMail.GetInspector.WordEditor
Related
I am Using windows 10, Excel 2013 and Outlook 2013
I am new to Macro. I need macro to perform below Task:
1) From Excel I want to open Outlook if Outlook is closed and move Point.2, If outlook is already open then move to Point.2
2) Search for a specific email in outlook in all folders and sub folders with criteria “A” and “B”
a) Latest dated received or sent email.
b) With specific Subject contains “Approved”, this to be taken from active cell.
3) Open the found latest mail as per above criteria do “Reply all”.
4) Write a comment and display the mail or send.
Below code was my start, but it has the following issues:
The code search for the exact name, while i need to search for any email contain the word which in active cell.
The code search only in sent emails, while i need to search in both inbox and sent.
The code just open the email, i need to write template comment as well.
Many thanks in advance.
Sub ReplyMail_No_Movements()
' Outlook's constant
Const olFolderSentMail = 5
' Variables
Dim OutlookApp As Object
Dim IsOutlookCreated As Boolean
Dim sFilter As String, sSubject As String
' Get/create outlook object
On Error Resume Next
Set OutlookApp = GetObject(, "Outlook.Application")
If Err Then
Set OutlookApp = CreateObject("Outlook.Application")
IsOutlookCreated = True
End If
On Error GoTo 0
' Restrict items
sSubject = ActiveCell.Value
sFilter = "[Subject] = '" & sSubject & "'"
' Main
With OutlookApp.Session.GetDefaultFolder(olFolderSentMail).Items.Restrict(sFilter)
If .Count > 0 Then
.Sort "ReceivedTime", True
With .Item(1).replyall
.Display
'.Send
End With
Else
MsgBox "No emails found with Subject:" & vbLf & "'" & sSubject & "'"
End If
End With
' Quit Outlook instance if it was created by this code
If IsOutlookCreated Then
OutlookApp.Quit
Set OutlookApp = Nothing
End If
End Sub
It seems work now:
Sub ReplyAllLastEmailFromInboxAndSent()
Dim olApp As Outlook.Application
Dim olNs As Namespace
Dim Fldr As MAPIFolder
Dim objMail As Object
Dim objReplyToThisMail As MailItem
Dim lngCount As Long
Dim objConversation As Conversation
Dim objTable As Table
Dim objVar As Variant
Dim strBody As String
Dim searchFolderName As String
Set olApp = Session.Application
Set olNs = olApp.GetNamespace("MAPI")
Set Fldr = olNs.GetDefaultFolder(olFolderSentMail)
searchFolderName = "'" & Outlook.Session.GetDefaultFolder(olFolderInbox).FolderPath & "','" & Outlook.Session.GetDefaultFolder(olFolderSentMail).FolderPath & "'"
lngCount = 1
For Each objMail In Fldr.Items
If TypeName(objMail) = "MailItem" Then
If InStr(objMail.Subject, ActiveCell.Value) <> 0 Then
Set objConversation = objMail.GetConversation
Set objTable = objConversation.GetTable
objVar = objTable.GetArray(objTable.GetRowCount)
Set objReplyToThisMail = olApp.Session.GetItemFromID(objVar(UBound(objVar), 0))
With objReplyToThisMail.replyall
strBody = "Dear " & "<br>" & _
"<p>Following up with the below. May you please advise?" & _
"<p>Thank you," & vbCrLf
.HTMLBody = strBody & .HTMLBody
.Display
End With
Exit For
End If
End If
Next objMail
Set olApp = Nothing
Set olNs = Nothing
Set Fldr = Nothing
Set objMail = Nothing
Set objReplyToThisMail = Nothing
lngCount = Empty
Set objConversation = Nothing
Set objTable = Nothing
If IsArray(objVar) Then Erase objVar
End Sub
This is the first time I am trying from Excel to send email using VBA code.
Here is my structure of my Excel. Sometimes the email list will have 1 - 20 or only 1 also
A (col) B C D E F G
Sl.No First Name To Email CC Email Subj File to Send Message
Code:
Option Explicit
Sub SendMail()
Dim objOutlook As Object
Dim objMail As Object
Dim rngTo As Range
Dim rngSubject As Range
Dim rngBody As Range
Dim rngAttach As Range
Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)
With ActiveSheet
Set rngTo = .Range("C2")
Set rngSubject = .Range("E2")
Set rngBody = .Range("G2")
Set rngAttach = .Range("F2")
End With
With objMail
.To = rngTo.Value
.Subject = rngSubject.Value
.Body = rngBody.Value
.Attachments.Add rngAttach.Value
.Display
End With
Set objOutlook = Nothing
Set objMail = Nothing
Set rngTo = Nothing
Set rngSubject = Nothing
Set rngBody = Nothing
Set rngAttach = Nothing
End Sub
Here is my code this was working perfectly fine but for single emails to send, but not for multiple email.
I am struggling here to find how to send for multiple email with attachment using the tested code.
Maybe Try this:
Option Explicit
Sub SendMail()
Dim objOutlook As Object
Dim objMail As Object
Dim rngTo As Range
Dim rngSubject As Range
Dim rngBody As Range
Dim rngAttach As Range
Dim i As Integer
Set objOutlook = CreateObject("Outlook.Application")
For i = 2 To 21 ' Loop from 2 to 21
With ActiveSheet
Set rngTo = .Range("C" & i)
Set rngSubject = .Range("E" & i)
Set rngBody = .Range("G" & i)
Set rngAttach = .Range("F" & i)
End With
Set objMail = objOutlook.CreateItem(0)
With objMail
.To = rngTo.Value
.Subject = rngSubject.Value
.HTMLBody = "<B><U>" & rngBody.Value & ":</B></U>"
.Attachments.Add rngAttach.Value
.Display
End With
Set objMail = Nothing
Next
Set objOutlook = Nothing
Set rngTo = Nothing
Set rngSubject = Nothing
Set rngBody = Nothing
Set rngAttach = Nothing
End Sub
You can loop through the Range to generate 20 emails.
Update
Added .HTMLBody instead of .Body to make text Bold And Underlined
You can use more HTML commands to make certain portions of the Text Bold and More.
Try it this way.
Make a list in Sheets("Sheet1") with :
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
You need a loop for that. The below code will start with the second row and continue until it finds an empty row.
Option Explicit
Sub SendMail()
Dim objOutlook As Object
Dim objMail As Object
Dim rngTo As Range
Dim rngSubject As Range
Dim rngBody As Range
Dim rngAttach As Range
Set objOutlook = CreateObject("Outlook.Application")
Dim r As Long: For r = 2 To ActiveSheet.Range("C2").End(xlDown).Row
With ActiveSheet
Set rngTo = .Range("C" & r)
Set rngSubject = .Range("E" & r)
Set rngBody = .Range("G" & r)
Set rngAttach = .Range("F" & r)
End With
Set objMail = objOutlook.CreateItem(0)
With objMail
.to = rngTo.Value
.Subject = rngSubject.Value
.Body = rngBody.Value
.Attachments.Add rngAttach.Value
.Display
.Send ' If you want to send it without clicking
End With
Next
End Sub
Also note: These Set x = Nothing lines are superfluous, delete them because they just make the code less readable for humans. Regarding this issue you can also refer to this SO question: Is there a need to set Objects to Nothing inside VBA Functions
Update
Sorry this line has to be inside the loop, I updated the code:
Set objMail = objOutlook.CreateItem(0)
I already made this code, I want to send a image already exist inside the Excel (called Picture 1810) by e-mail. But I cant discovery how to do the .Body.
Anyone can help me?
Sub CreateMail()
Dim objOutlook As Object
Dim objMail As Object
Dim rngTo As Range
Dim rngCC As Range
Dim rngSubject As Range
Dim rngBody As Shape
Dim rngAttach As Range
Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)
With ActiveSheet
Set rngTo = .Range("f2")
Set rngCC = .Range("f3")
Set rngSubject = .Range("c2")
Set rngBody = .Shapes("Picture 1810")
End With
With objMail
.To = rngTo.Value
.CC = rngCC.Value
.Subject = rngSubject.Value
.Body = rnbbody
.Send
End With
Set objOutlook = Nothing
Set objMail = Nothing
Set rngTo = Nothing
Set rngSubject = Nothing
Set rngBody = Nothing
Set rngAttach = Nothing
End Sub
By this you retain your standard email signature and paste the shape either floating over the body text or like a character in between:
With objMail
.To = rngTo.Value
.CC = rngCC.Value
.Subject = rngSubject.Value
.Display
Dim wdDoc As Word.Document
Set wdDoc = .GetInspector.WordEditor
If Not wdDoc Is Nothing Then
With wdDoc.Range
.Collapse wdCollapseStart
.InsertBefore "Hi there," & vbCrLf & "here's my shape:" & vbCrLf
.Collapse wdCollapseEnd
.InsertAfter vbCrLf & "Best wishes," & vbCrLf
.Collapse wdCollapseStart
ActiveSheet.Shapes("Picture 1810").Copy
'.Paste ' over the text
.PasteAndFormat wdChartPicture ' within text
End With
Set wdDoc = Nothing
End If
'.Send
End With
I'm trying to copy a range in Excel as a picture to Outlook mail and add text in the body as well.
My code is adding the text and then pasting the picture on top of it. How can I get it to paste under the text?
Dim OutApp As Object
Dim outMail As Object
Dim myFileList(1) As String
Dim i As Long
Set OutApp = CreateObject("Outlook.Application")
Set outMail = OutApp.CreateItem(0)
Set RngCopied = Worksheets("Daily volume summary").Range("VolumeRange")
myFileList(0) = "Y:xyz\sales.pdf"
myFileList(1) = "Y:xyz\sales.xlsx"
'On Error Resume Next
With outMail
.To = "abc#xyz.com"
.CC = "def#xyz.com"
.BCC = ""
.Subject = "PBC Daily Sales " & Format(Date, "mm/dd/yyyy")
.Body = "Good morning," & vbNewLine & vbNewLine & "Attach is the Daily Sales report for " & Format(Date, "dddd,mmmm,dd,YYYY") & "." & "<br>"
'Copy range of interest
Dim r As Range
Set r = Worksheets("Daily volume summary").Range("VolumeRange")
r.Copy
'Get its Word editor
outMail.Display
Dim wordDoc As Word.Document
Set wordDoc = outMail.GetInspector.WordEditor
'To paste as picture
wordDoc.Range.PasteAndFormat wdChartPicture
Dim shp As Object
For Each shp In wordDoc.InlineShapes
shp.ScaleHeight = 60
shp.ScaleWidth = 60
Next
For i = 0 To UBound(myFileList)
.Attachments.Add myFileList(i)
Next
.Send
End With
On Error GoTo 0
Set outMail = Nothing
Set OutApp = Nothing
End Sub
In the line:
wordDoc.Range.PasteAndFormat wdChartPicture
you are replacing the ENTIRE range of the message's word doc with your picture. Instead you need to note where in the range you want to paste this. This should put it after your text:
wordDoc.Range(start:=wordDoc.Range.End - 2).PasteAndFormat wdChartPicture
I have a template that is stationed in an excel file. Once I click the preview button, this template will be displayed in outlook as well as its subject, to and etc.
I have this code that works fine but is not working in the body field.
Sub previewMail()
Dim objMail, objOutLook As Object
Dim rngTo, rngCC, rngBCC, rngBody As Range
Dim lRow As Long
Dim i As Integer
Set objOutLook = CreateObject("Outlook.Application")
Set objMail = objOutLook.CreateItem(0)
Set main = ThisWorkbook.Sheets("Main")
lRow = main.Cells(Rows.Count, 2).End(xlUp).Row
For i = 11 To lRow
With main
Set rngTo = .Range("B" & i)
Set rngBody = .Range(.Range("C10:N30"), .Range("C10:N30"))
End With
With objMail
.To = rngTo.Value
.Subject = "Sample"
'i like the rngbody to be here
.HTMLBody = RangetoHTML(rngBody)' from Ron de Bruin site
.Display
End With
Next i
End Sub
This is the template stationed in the said range above.
Can anyone please help me figure this out? I have tried this from Ron de Bruin but I can't make it work. This only gives a product that is an "invisible table".
EDIT: OP has indicated text is not in range, but in a textbox in front of range.
Use this code to find the textbox name:
for i = 1 to activesheet.chartobjects.count
debug.print chartobjects(i).name
next i
It will be like Textbox1 or something, then use(untested):
dim strBody as string
Set strBody = activesheet.chartobjects("Textbox1").Value
.HTMLBody = strbody
Try Range.PasteAndFormat wdChartPicture
Example
Option Explicit
Sub previewMail()
Dim objMail, Main, objOutLook As Object
Dim rngTo, rngCC, rngBCC, rngBody As Range
Dim lRow As Long
Dim i As Integer
Dim wordDoc As Word.Document '<---
Set objOutLook = CreateObject("Outlook.Application")
Set objMail = objOutLook.CreateItem(0)
Set Main = ThisWorkbook.Sheets("Main")
Set wordDoc = objMail.GetInspector.WordEditor '<---
lRow = Main.Cells(Rows.count, 2).End(xlUp).Row
For i = 11 To lRow
With Main
Set rngTo = .Range("B" & i)
Set rngBody = .Range(.Range("C10:N30"), .Range("C10:N30"))
rngBody.Copy '<---
End With
With objMail
.To = rngTo.Value
.Subject = "Sample"
.Display
wordDoc.Range.PasteAndFormat wdChartPicture '<---
' Or
'wordDoc.Range.PasteAndFormat wdChartPicture & .HTMLBody = " "
End With
Next i
End Sub
Make sure to set references to the Microsoft Outlook and Microsoft Word Object libraries
Tools > References...