Excel 宏通过 Outlook 通过电子邮件发送表格和图表

问题描述 投票：0回答：2

我正在尝试通过 Outlook 邮件从 Excel 向用户发送自动化邮件。其中我需要向某些用户发送一些 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

提前致谢 库纳尔...

vba excel mailmerge
2个回答
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

谢谢， 库纳尔...

0
投票

嗨，运行此宏时，我收到以下错误

在解析 json 时，您能解决这个问题吗？

最新问题
© www.soinside.com 2019 - 2024. All rights reserved.