CODEWITHSUNDEEP
excelvbaoutlook
Tayyab
Tayyab

Reputation: 65

Copy list of emails to Outlook

Can someone help me with below code? Here is a piece of code that is intended to copy a list of emails id's from "Sheet1" cells "B2" to "n" number of rows having data.

I am facing two issues with this.

1) HTMLBody text is not copied to email.
2) List of email recipient available at Sheet1, B2 onward is not getting copied on email recipient list ("To" list).

Thanks in advance!

Sub MeetingMacro()
'MsgBox Hour(Now)
If Weekday(Now, vbMonday) >= 6 And Hour(Now) > 12 Then
Exit Sub
End If

Application.ScreenUpdating = False

Dim pt As PivotTable
Set pt = ThisWorkbook.Sheets("Sheet2").PivotTables("PivotTable")
pt.RefreshTable
Application.CalculateUntilAsyncQueriesDone
Call saveAsXlsx1
Application.CalculateUntilAsyncQueriesDone
Call savefile
Application.CalculateUntilAsyncQueriesDone
Call Send_Range
'Call Send_Range


End Sub

Sub Send_Range()

   Dim TBL As ListObject
     ThisWorkbook.Activate

   ThisWorkbook.EnvelopeVisible = False
   ThisWorkbook.Sheets("Sheet2").Range("A1:B30").Select
    ThisWorkbook.Activate
   With ActiveSheet.MailEnvelope

            SDest = ""
       For iCounter = 2 To WorksheetFunction.CountA(Columns(3))
           If SDest = "" Then
               SDest = Cells(iCounter, 3).Value
               SDest.Value.Select
           Else
               SDest = SDest & ";" & Cells(iCounter, 3).Value
           End If
       Next iCounter

      .Item.To = SDest
      .Item.CC = "[email protected]"
      .Item.Subject = "[URGENT] Meeting has been cancelled. "
      .Item.HTMLBody = "Hello," & vbCrLf & "Meeting has been cancelled. Fresh invite will be sent soon.” & vbCrLf & "Regards"
      .Item.Attachments.Add "C:\Attachment.xlsx" 'ActiveWorkbook.FullName
      .Item.Send
   End With

   'MsgBox (TimeOfDay)
End Sub


'MsgBox (TimeOfDay)
Sub savefile()
 Application.ScreenUpdating = False
     ThisWorkbook.Activate
     Application.ScreenUpdating = True
ThisWorkbook.Save
End Sub
Sub saveAsXlsx1()
ThisWorkbook.Worksheets(Array("Sheet2")).Copy
Application.DisplayAlerts = False
 ActiveSheet.Shapes.Range("FetchData").Delete
ActiveWorkbook.SaveAs Filename:="C:\Attachment.xlsx"
ActiveWorkbook.Close
End Sub

Sub Meeting4()
ThisWorkbook.Application.DisplayAlerts = False
ActiveWorkbook.Save
ThisWorkbook.Close
End Sub

Upvotes: 0

Views: 165

Answers (1)

Mathieu Guindon
Mathieu Guindon

Reputation: 71187

Say you have cells B2:B30 (all in the same column) in Sheet1, containing email addresses. What you want is to grab the values in these cells, and turn them into a one-dimensional array - that's done like this:

Dim values As Variant
values = Application.WorksheetFunction.Transpose(Sheet1.Range("B2:B30").Value)

With a one-dimensional array of email addresses, all you need to do is to turn it into a String. The Join function is made exactly for that:

Dim recipients As String
recipients = Join(values, ";")

That's all! ...assuming the cells all contain an email address string. If one cell contains an error value, expect trouble. If there are blanks, expect blanks (shouldn't make a difference though). If the range to grab isn't carved in stone, research how to make it more dynamic.

The HtmlBody is expecting an HTML-encoded string that contains HTML markup. If you only have plain text, use the Body property instead.

Upvotes: 1

Related Questions