Excel 宏通過 Outlook 通過電子郵件發送表格和圖形

Question

我正在嘗試通過 Outlook 郵件從 Excel 向用戶發送 Automate 郵件。 其中我需要向某些用戶發送一些 Excel 表格和圖表。 excel表格應放在發件人提供/編寫的一些文本之后，並應在電子郵件中保留相同的表格格式。

我無法自動獲得此功能（在電子郵件正文中發送 excel 表格和圖表），需要您的幫助來解決這個問題。

PS：我使用的是 excel/Outlook 2010 (win)

以下是我目前編寫的整體代碼：

Sub Mail_to_MgmtTeam()

Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String

Dim rng As Range

Dim x As Integer, y As Integer
Dim total_Resource As Integer

Application.ScreenUpdating = False

' Delete the Temp sheets, if any (just precautionary step)
Application.DisplayAlerts = False
On Error Resume Next
Sheets("Temp").Delete
Application.DisplayAlerts = True
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Temp"

Sheets("Mail Details").Select
Range("A5").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Temp").Select
Range("A5").Select
ActiveSheet.Paste
Application.CutCopyMode = False

Columns("J:J").EntireColumn.Delete
Columns("A:A").EntireColumn.Delete
Range("A5").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select

'' Below code not getting executed successfully
'Selection.Select
'Set rng = Sheets("Temp").Selection.SpecialCells(xlCellTypeVisible)
'rng.Copy

' NEED HELP Here : TO send this selected TABLE within the email BODY to someone...

' code for sending the mails form Excel
Sheets("Mail Details").Select
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

strbody = "Dear " & Cells(x + 5, 3).Value & ", " & _
       vbNewLine & vbNewLine & _
       "Below Table provides the overall statue of Pending Lists." & _
         vbNewLine & vbNewLine & vbNewLine & _
      "Thank You " & vbNewLine & "XYZ..."

On Error Resume Next
With OutMail
    .To = Sheets("Mail Details").Range("D6").Value
    .CC = ""
    .BCC = ""
    .Subject = "Excel Table Attached"
    .Body = strbody
    .Send
End With

On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing

MsgBox "Mails have been sent", vbDefaultButton1, "Mail Sent!!!"

End Sub

在此先感謝庫納爾...

Answer 1

我能夠完成我發布的任務。 我將在下面為將來可能需要幫助的任何人發布最終代碼...

PS：

為了便於使用，我已經分成了不同的組。 請復制每個代碼並將其粘貼到“模塊”中
工作表名稱應為“RawData”和“ReportData”
表格應放在工作表“RawData”中，列標題應在第 5 行
在“RawData”表中，在 K 列中，提到了郵件 ID

宏 #1

Option Explicit
Dim folder_path As String
Dim chart_no As Integer
Dim file_path As String

Sub mail_2_IBUhead()

Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Dim rng As Range
Dim x As Integer, y As Integer
Dim total_Resource As Integer

Application.ScreenUpdating = False

Sheets("RawData").Select

Call export_chart

Call Send_Automate_Mail

Sheets("RawData").Select
Range("A1").Select

'Delete the htm file we used in this function
Kill file_path & "Chart_1.png"

MsgBox "Draft Mails have been generated", vbDefaultButton1, "Mail Drafted!!!"


End Sub

宏 #2：

Private Sub Send_Automate_Mail()
' This macro would only send the mail...

Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim strbody_1 As String, strbody_2 As String, strbody_3 As String
Dim Start_row As Integer, Start_column As Integer, End_row As Integer, End_Column As Integer

' selecting the entire table range in the sheet
Sheets("RawData").Select
Range("A5").Select
Start_row = Selection.Row
Start_column = Selection.Column
Selection.End(xlToRight).Select
End_Column = Selection.Column
Range("A5").End(xlDown).Select
End_row = Selection.Row

Range(Cells(Start_row, 1), Cells(End_row, End_Column)).Select

Set rng = Selection.SpecialCells(xlCellTypeVisible)

If rng Is Nothing Then
    MsgBox "The selection is not a range or the sheet is protected. " & _
           vbNewLine & "Please correct and try again.", vbOKOnly
    Exit Sub
End If

With Application
    .EnableEvents = False
    .ScreenUpdating = False
End With

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)


strbody_1 = "<BODY style=font-size:11pt;font-family:Calibri>Dear User,<p>" & _
            " Below is the Graph.... <br> </BODY> "

strbody_2 = "<BODY style=font-size:11pt;font-family:Calibri>" & _
            " Below is the Table... <br> </BODY> "

strbody_3 = "<BODY style=font-size:11pt;font-family:Calibri> This is an Automated mail. Please do not respond. <p> <p> " & _
            " Regards, <br> Sender </BODY> "

file_path = folder_path & "\"

With OutMail
    .To = Sheets("RawData").Range("k6").Value
    .CC = ""
    .BCC = ""
    .Subject = "BE. RawData"
    .Attachments.Add file_path & "Chart_1.png"
    .htmlbody = strbody_1 & "<p>" & "<p>" & _
                "<img src='cid:Chart_1.png'" & "width='1000' height='580'>" & "<br>" & "<p>" & _
                strbody_2 & "<p>" & _
                RangetoHTML(rng) & "<br>" & _
                strbody_3
    .Importance = 2
    ' display the e-mail message, change it to ".send" to send the mail on running the macro
    .Display
End With
On Error GoTo 0

With Application
    .EnableEvents = True
    .ScreenUpdating = True
End With

Set OutMail = Nothing
Set OutApp = Nothing

End Sub

宏 #3：

Function RangetoHTML(rng As Range)
' this function is used in code "Send_Automate_Mail"
' do not change the code if you are new to coding :)
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook

TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

'Copy the range and create a new workbook to past the data in
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
    .Cells(1).PasteSpecial Paste:=8
    .Cells(1).PasteSpecial xlPasteValues, , False, False
    .Cells(1).PasteSpecial xlPasteFormats, , False, False
    .Cells(1).Select
    Application.CutCopyMode = False
    On Error Resume Next
    .DrawingObjects.Visible = True
    .DrawingObjects.Delete
    On Error GoTo 0
End With

'Publish the sheet to a htm file
With TempWB.PublishObjects.Add( _
     SourceType:=xlSourceRange, _
     Filename:=TempFile, _
     Sheet:=TempWB.Sheets(1).Name, _
     Source:=TempWB.Sheets(1).UsedRange.Address, _
     HtmlType:=xlHtmlStatic)
    .Publish (True)
End With

'Read all data from the htm file into RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.ReadAll
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", "align=left x:publishsource=")

TempWB.Close savechanges:=False
Kill TempFile

Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing

End Function

宏#4：

Private Sub export_chart()
' this code will export all the graphs present in the sheet

Dim objCht As ChartObject
Dim x As Integer

folder_path = Application.ActiveWorkbook.Path

' for each graph present in the sheet, it will get exported
Sheets("ReportData").Select
x = 1
For Each objCht In ActiveSheet.ChartObjects
    objCht.Chart.Export folder_path & "\Chart_" & x & ".png", "PNG"
    x = x + 1
Next objCht

End Sub

謝謝，庫納爾...

Excel 宏通過 Outlook 通過電子郵件發送表格和圖形

問題描述

1 個解決方案

解決方案1
1 已采納 2016-05-17 09:39:59

Excel 宏通過 Outlook 通過電子郵件發送表格和圖形

問題描述

1 個解決方案

解決方案1 1 已采納 2016-05-17 09:39:59

解決方案1
1 已采納 2016-05-17 09:39:59