I have this code, but I need to alter it, and I am not sure how. I need it to do the follow:
1. Access a template rather than a traditional plain email. Path & file name below
C:Usersbarnes22AppDataRoamingMicrosoftTemplatesVOC.oft
2. Not use an input box for the range. I would like that sheet name and range to be hardcoded in the VBA "SurveyVoC" is the sheet, and B2:B500 is the range
Sub sendmultiple()
Dim xOTApp As Object
Dim xMItem As Object
Dim xCell As Range
Dim xRg As Range
Dim xEmailAddr As String
Dim xTxt As String
On Error Resume Next
xTxt = ActiveWindow.RangeSelection.Address
Set xRg = Application.InputBox("Please select the addresses list"
If xRg Is Nothing Then Exit Sub
Set xOTApp = CreateObject("Outlook.Application")
For Each xCell In xRg
If xCell.Value Like "*@*" Then
If xEmailAddr = "" Then
xEmailAddr = xCell.Value
Else
xEmailAddr = xEmailAddr & ";" & xCell.Value
End If
End If
Next
Set xMItem = xOTApp.CreateItem(0)
With xMItem
.To = xEmailAddr
.Display
End With
End Sub
Hi, I hope this makes sense:
Sub sendmultiple()
Const mailTemplate As String = "C:Usersbarnes22AppDataRoamingMicrosoftTemplatesVOC.oft"
Const mailSheet As String = "SurveyVoC"
Dim wb As Workbook
Dim ws As Worksheet
Dim xOTApp As Object
Dim xMItem As Object
Dim xCell As Range
Dim xRg As Range
Dim xEmailAddr As String
Dim xTxt As String
On Error Resume Next
Set wb = ThisWorkbook
Set ws = wb.Worksheets(mailSheet)
'* You will have to set the worksheet's range that contains the email addresses here
Set xRg = ws.Range("A2:A" & ws.Cells(Rows.Count, "A").End(xlUp).Row)
'xTxt = ActiveWindow.RangeSelection.Address
'Set xRg = Application.InputBox("Please select the addresses list"
If xRg Is Nothing Then Exit Sub
xEmailAddr = ""
For Each xCell In xRg
If xCell.Value Like "*@*" Then
If xEmailAddr = "" Then
xEmailAddr = xCell.Value
Else
xEmailAddr = xEmailAddr & ";" & xCell.Value
End If
End If
Next
If xEmailAddr <> "" Then
Set xOTApp = CreateObject("Outlook.Application")
Set xMItem = xOTApp.CreateItem(0)
With xMItem
.To = xEmailAddr
.Display
End With
End If
End Sub
That did not quite work. First, it did not work out as planned. The template (VOC.oft) was not accessed, only a normal "white" email opened. I verified the path and it is correct. Also, I changed the column from A to B, as B is where the email addresses are. But my form contains over 6K emails, all of which were placed on the email, and the email stated it would only be sent to 500 people. What did I do wrong???
Const mailTemplate As String = "C:Usersbarnes22AppDataRoamingMicrosoftTemplatesVOC.oft"
Const mailSheet As String = "SurveyVoC"
Dim wb As Workbook
Dim ws As Worksheet
Dim xOTApp As Object
Dim xMItem As Object
Dim xCell As Range
Dim xRg As Range
Dim xEmailAddr As String
Dim xTxt As String
On Error Resume Next
Set wb = ThisWorkbook
Set ws = wb.Worksheets(mailSheet)
'* You will have to set the worksheet's range that contains the email addresses here
Set xRg = ws.Range("B2:B" & ws.Cells(Rows.Count, "B").End(xlUp).Row)
'xTxt = ActiveWindow.RangeSelection.Address
'Set xRg = Application.InputBox("Please select the addresses list"
If xRg Is Nothing Then Exit Sub
xEmailAddr = ""
For Each xCell In xRg
If xCell.Value Like "*@*" Then
If xEmailAddr = "" Then
xEmailAddr = xCell.Value
Else
xEmailAddr = xEmailAddr & ";" & xCell.Value
End If
End If
Next
If xEmailAddr <> "" Then
Set xOTApp = CreateObject("Outlook.Application")
Set xMItem = xOTApp.CreateItem(0)
With xMItem
.To = xEmailAddr
.Display
End With
End If
End Sub
Set xMItem = xOTApp.CreateItem(0)
should be:
Set xMItem = xOTApp.CreateItemFromTemplate(mailTemplate)
I suspect (hope) Outlook will not allow you to put 6k email addresses into the To field.
