I would like to generate four Outlook emails.
I got this error:
runtime error 91
at: rng = "rng" & i.
Sub generate4emails()
Dim OutApp As Object, OutMail As Object
Dim i As Integer
Dim rng As Range, rng1 As Range, rng2 As Range, rng3 As Range, rng4 As Range
Set rng1 = ThisWorkbook.Sheets("Sheet1").Range("C12:F14")
Set rng2 = ThisWorkbook.Sheets("Sheet1").Range("C16:F18")
Set rng3 = ThisWorkbook.Sheets("Sheet1").Range("H12:K14")
Set rng4 = ThisWorkbook.Sheets("Sheet1").Range("H16:K18")
For i = 1 To 4
Set Outappp = CreateObject("Outlook.application")
Set OutMail = OutApp.Createitem(0)
rng = "rng" & i
With OutMail
.To = ThisWorkbook.Sheets("Sheet1").Range("A1").Value
.Subject = "Notice" & i
.HTMLBody = RangetoHTML(rng)
.display
End With
Set OutMail = Nothing
Next i
End Sub
Declare your ranges as array instead of multiple variables so you can loop through that array:
Sub generate4emails()
Dim OutApp As Object, OutMail As Object
Dim i As Long
Dim rng(1 To 4) As Range
Set rng(1) = ThisWorkbook.Sheets("Sheet1").Range("C12:F14")
Set rng(2) = ThisWorkbook.Sheets("Sheet1").Range("C16:F18")
Set rng(3) = ThisWorkbook.Sheets("Sheet1").Range("H12:K14")
Set rng(4) = ThisWorkbook.Sheets("Sheet1").Range("H16:K18")
For i = 1 To 4
Set Outappp = CreateObject("Outlook.application")
Set OutMail = OutApp.Createitem(0)
With OutMail
.To = ThisWorkbook.Sheets("Sheet1").Range("A1").Value
.Subject = "Notice" & i
.HTMLBody = RangetoHTML(rng(i))
.display
End With
Set OutMail = Nothing
Next i
End Sub
Note, when ever you have the feeling you need to number your variables you can be sure you are doing it wrong. Always use arrays instead.
You can even improve this to a minimum:
Sub generate4emails()
Dim OutApp As Object, OutMail As Object
Dim i As Long
Dim RngAddresses As Variant
RngAddresses = Array("C12:F14", "C16:F18", "H12:K14", "H16:K18")
For i = LBound(RngAddresses) To UBound(RngAddresses)
Set Outappp = CreateObject("Outlook.application")
Set OutMail = OutApp.Createitem(0)
With OutMail
.To = ThisWorkbook.Sheets("Sheet1").Range("A1").Value
.Subject = "Notice" & i + 1
.HTMLBody = RangetoHTML(ThisWorkbook.Sheets("Sheet1").Range(RngAddresses(i))
.display
End With
Set OutMail = Nothing
Next i
End Sub
Note that if you generate an array with Array() it starts counting with 0 not with 1!
Please, try the next adapted way:
Sub generate4emails()
Dim OutApp As Object, OutMail As Object
Dim i As Integer
Dim rng As Range, rng1 As Range, rng2 As Range, rng3 As Range, rng4 As Range, arrRng
Set rng1 = ThisWorkbook.Sheets("Sheet1").Range("C12:F14")
Set rng2 = ThisWorkbook.Sheets("Sheet1").Range("C16:F18")
Set rng3 = ThisWorkbook.Sheets("Sheet1").Range("H12:K14")
Set rng4 = ThisWorkbook.Sheets("Sheet1").Range("H16:K18")
arrRng = Array(rng1, rng2, rng3, rng4)
For i = 0 To UBound(arrRng)
Set Outappp = CreateObject("Outlook.application")
Set OutMail = OutApp.CreateItem(0)
Set rng = arrRng(i)
With OutMail
.To = ThisWorkbook.Sheets("Sheet1").Range("A1").value
.Subject = "Notice" & i
.HtmlBody = RangetoHTML(rng)
.Display
End With
Set OutMail = Nothing
Next i
End Sub
Related
I found the following script here:
Sub emailtest()
Dim objOutlook As Object
Dim objMail As Object
Dim rngTo As Range
Dim rngSubject As Range
Dim rngBody As Range
Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)
With ActiveSheet
Set rngTo = .Range("E2")
Set rngSubject = .Range("E3")
Set rngBody = .Range("E4")
End With
With objMail
.To = rngTo.Value
.Subject = rngSubject.Value
.Body = rngBody.Value
.Attachments.Add "Z:\PHS 340B\Letters of Non-Compliance\..Resources\W9 Form\VPNA W-9 01 09 2017"
.Display 'Instead of .Display, you can use .Send to send the email _
or .Save to save a copy in the drafts folder
End With
Set objOutlook = Nothing
Set objMail = Nothing
Set rngTo = Nothing
Set rngSubject = Nothing
Set rngBody = Nothing
End Sub
I changed Set rngTo = .Range("E2") to Set rngTo = .Range("G8:G38") , running the script it gives a 440 Error on :.to = rngTo.Value
What am I doing wrong?
What Tim said above. Try this.
Dim objOutlook As Object
Dim objMail As Object
Dim rngTo As Range
Dim rngSubject As Range
Dim rngBody As Range
Dim emails as string
Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)
With ActiveSheet
Set rngTo = .Range("G8:G38")
Set rngSubject = .Range("E3")
Set rngBody = .Range("E4")
End With
For Each E In rngTo
emails = emails & E & ";"
Next
With objMail
.To = emails
.Subject = rngSubject.Value
.Body = rngBody.Value
'.Attachments.Add "Z:\PHS 340B\Letters of Non-Compliance\..Resources\W9 Form\VPNA W-9 01 09 2017"
.Display 'Instead of .Display, you can use .Send to send the email _
or .Save to save a copy in the drafts folder
End With
Set objOutlook = Nothing
Set objMail = Nothing
Set rngTo = Nothing
Set rngSubject = Nothing
Set rngBody = Nothing
I copy a range and paste into Outlook email with signature.
I want to reflect the range in center of body of email.
Dim OutApp As Object
Dim OutMail As Object
Dim rng As Range
Set rng = Nothing
Set rng = ThisWorkbook.Sheets("Output").Range("D7:E18")
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = ""
.BCC = ""
.Subject = "Subject"
.Display
Dim wdDoc As Object
Dim wdRange As Object
Set wdDoc = OutMail.GetInspector.WordEditor
Set wdRange = wdDoc.Range(0, 0)
wdRange.InsertAfter vbCrLf & vbCrLf
rng.Copy
wdRange.Paste
Set OutMail = Nothing
Set OutApp = Nothing
End With
What the code does is, it centers not only the text but also the table (Excel Range) pasted in the outlook body.
Option Explicit
Const wdAlignRowCenter As Integer = 1
Const wdAlignParagraphCenter As Integer = 1
Sub Sample()
Dim OutApp As Object, OutMail As Object
Dim wdDoc As Object, wdRange As Object
Dim rng As Range
Dim i As Long
Set rng = ThisWorkbook.Sheets("Output").Range("D7:E18")
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = ""
.BCC = ""
.Subject = "Subject"
.Display
Set wdDoc = .GetInspector.WordEditor
Set wdRange = wdDoc.Range(0, 0)
wdRange.InsertAfter vbCrLf & vbCrLf
rng.Copy
wdRange.Paste
DoEvents
Set wdRange = wdDoc.Range(0, wdDoc.Characters.Count)
wdRange.ParagraphFormat.Alignment = wdAlignParagraphCenter
For i = 1 To wdRange.Tables.Count
wdRange.Tables(i).Rows.Alignment = wdAlignRowCenter
Next i
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Note:
BTW Set wdDoc = .GetInspector.WordEditor will give you error if the default editor is not MS Word...
If there are images in your body then you may have to handle them as well seperately
I am sure this is something simple the code below works for the first entry in the list but does not loop, I literally cannot figure this out
Can anyone shed any light on correcting this loop, please?
I have tried moving the loop inside the 'With OutMail' section, I have tried a do while loop.
Sub Send_Emails()
Dim OutApp As Object: Set OutApp = CreateObject("Outlook.Application")
Dim OutMail As Object: Set OutMail = OutApp.CreateItem(0)
Dim r As Range
Dim rCell As Range
Dim path As String
Dim rows As Integer
Set r = ActiveWorkbook.Sheets("Distribution List").UsedRange
'Row = Sheets("Distribution List").rows.count
'Send Email
For i = 2 To 20
With OutMail
att = r(i, 2).Value
em1 = r(i, 3).Value
em2 = r(i, 4).Value
path = "\\azfs\YFHPublic\Farms Project\Holds By Area\Holds by Area" & "\" & att
On Error Resume Next:
.SentOnBehalfOfName = "email#email.com"
.To = em1
.Subject = "invoices on hold"
.Body = "this is a test"
.Attachments.Add path
.Display
.Send
End With
OutMail = Nothing
OutApp = Nothing
i = i + 1
Next i
' OutMail = Nothing
' OutApp = Nothing
End Sub
I believe you're trying to make a new email for each person in the loop...
Sub Send_Emails()
Dim OutApp As Object: Set OutApp = CreateObject("Outlook.Application")
Dim OutMail As Object 'REMOVED SET FROM HERE
Dim r As Range
Dim rCell As Range
Dim path As String
Dim rows As Integer
Set r = ActiveWorkbook.Sheets("Distribution List").UsedRange
'Row = Sheets("Distribution List").rows.count
'Send Email
For i = 2 To 20
Set OutMail = OutApp.CreateItem(0) 'MOVED TO CREATE NEW MAILITEM FOR EACH LOOP
With OutMail
'OTHER CODE
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 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