How to copy pivot table in mail body of outlook using VBA?
I can send mail but I am unable to paste pivot table into mail body.? Below is my code.Private Sub CommandButton1_Click()Dim OutApp As Object Dim O
I can send mail but I am unable to paste pivot table into mail body.? Below is my code.
Private Sub CommandButton1_Click()
Dim OutApp As Object
Dim OutMail As Object
Dim emailRng As Range, cl As Range
Dim sTo As String
Dim sCC As String
Dim sBCC As String
Dim StrBody As String
Set emailRng = ThisWorkbook.Sheets("Master").Range("A2:A6")
For Each cl In emailRng
sTo = sTo & ";" & cl.Value
Next
sTo = Mid(sTo, 2)
Set emailRng = ThisWorkbook.Sheets("Master").Range("B2:B6")
For Each cl In emailRng
sCC = sCC & ";" & cl.Value
Next
sCC = Mid(sCC, 2)
Set emailRng = ThisWorkbook.Sheets("Master").Range("C2:C6")
For Each cl In emailRng
sBCC = sBCC & ";" & cl.Value
Next
sBCC = Mid(sBCC, 2)
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = sTo
.CC = sCC
.BCC = sBCC
.Subject = "MFN At Station"
.Body = Sheets("Master").Cells(2, 4) & vbNewLine & _
Sheets("Master").Cells(2, 5) & vbNewLine & _
Sheets("Master").Cells(2, 10) & vbNewLine & _
Sheets("Master").Cells(2, 6) & vbNewLine & _
Sheets("Master").Cells(2, 11) & vbNewLine & _
Sheets("Master").Cells(2, 7) & vbNewLine & _
Sheets("Master").Cells(2, 8)
.Attachments.Add ("C:\Users\ihameed\Desktop\test\tree.txt")
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
or:I can send mail but I am unable to paste pivot table into mail body.? Below is my code.Private Sub CommandButton1_Click()Dim OutApp As Object Dim OutMail As Object Dim emailRng As Range, cl As Range Dim sTo As String Dim sCC As String Dim sBCC As String Dim StrBody As String Set emailRng = ThisWorkbook.Sheets(\"Master\").Range(\"A2:A6\") For Each cl In emailRng sTo = sTo & \";\" & cl.Value Next sTo = Mid(sTo, 2) Set emailRng = ThisWorkbook.Sheets(\"Master\").Range(\"B2:B6\") For Each cl In emailRng sCC = sCC & \";\" & cl.Value Next sCC = Mid(sCC, 2) Set emailRng = ThisWorkbook.Sheets(\"Master\").Range(\"C2:C6\") For Each cl In emailRng sBCC = sBCC & \";\" & cl.Value Next sBCC = Mid(sBCC, 2) Set OutApp = CreateObject(\"Outlook.Application\") Set OutMail = OutApp.CreateItem(0) On Error Resume Next With OutMail .To = sTo .CC = sCC .BCC = sBCC .Subject = \"MFN At Station\" .Body = Sheets(\"Master\").Cells(2, 4) & vbNewLine & _ Sheets(\"Master\").Cells(2, 5) & vbNewLine & _ Sheets(\"Master\").Cells(2, 10) & vbNewLine & _ Sheets(\"Master\").Cells(2, 6) & vbNewLine & _ Sheets(\"Master\").Cells(2, 11) & vbNewLine & _ Sheets(\"Master\").Cells(2, 7) & vbNewLine & _ Sheets(\"Master\").Cells(2, 8) .Attachments.Add (\"C:\\Users\\ihameed\\Desktop\\test\\tree.txt\") .Send End With On Error GoTo 0 Set OutMail = Nothing Set OutApp = NothingEnd Sub
