如何从Outlookmacros发送Excel图表

我达到了运行规则和警报的前景macros的地步。

macros从邮件地址search邮件，当它find它时，它将它移动到一个子文件夹，然后只提取邮件正文中的数字，打开Excel，粘贴数字和邮件date到Excel下一个空闲行，更新Excel，保存并closures它。

最后它将邮件移动到DONE目录并将其标记为已读。

在Excel中有一个数据透视表来创build一个图表（图3）。

现在我想从excel发送graphics到邮件收件人，我发现很多方法从Excel邮件graphics，但不是从Outlookmacros。

这是我到目前为止：

Sub MoveItems(Item As Outlook.MailItem) '**************************************************************************** '* Find mail from sender and move them from the inbox to the rquests folder * '**************************************************************************** Dim myNameSpace As Outlook.NameSpace Dim myInbox As Outlook.Folder Dim myDestFolder As Outlook.Folder Dim myItems As Outlook.Items Dim myItem As Object Set myNameSpace = Application.GetNamespace("MAPI") Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox) Set myItems = myInbox.Items Set myDestFolder = myInbox.Folders("Rquests") Set myItem = myItems.Find("[SenderEmailAddress] = '[e-mail]'") While TypeName(myItem) <> "Nothing" If myItem.UnRead = True Then myItem.Move myDestFolder Set myItem = myItems.FindNext End If Wend '********************************************************* '* run the Process that extruct the number from the mail * '********************************************************* ProcessRequests End Sub --------------------------------------------------------------------------- Sub MoveItems2() '******************************************************************* '* Move the processed mail from the rquests to the RQ_Done folder * '******************************************************************* Dim myNameSpace As Outlook.NameSpace Dim mySourceFolder As Outlook.Folder Dim myDestFolder As Outlook.Folder Dim myItems As Outlook.Items Dim myItem As Object Set myNameSpace = Application.GetNamespace("MAPI") Set mySourceFolder = myNameSpace.GetDefaultFolder(olFolderInbox).Folders("Rquests") Set myItems = mySourceFolder.Items Set myDestFolder = mySourceFolder.Folders("RQ_Done") Set myItem = myItems.Find("[SenderEmailAddress] = '[e-mail]'") While TypeName(myItem) <> "Nothing" myItem.UnRead = False myItem.Move myDestFolder Set myItem = myItems.FindNext Wend End Sub --------------------------------------------------------------------------- Sub ProcessRequests() On Error Resume Next Set myOlApp = Outlook.Application Set myNameSpace = myOlApp.GetNamespace("mapi") Dim msgtext As String Dim TimeStamp As Date 'set the outlook folder to look at Set myfolder = myNameSpace.GetDefaultFolder(olFolderInbox).Folders("Rquests") 'set excel parameters Dim xlApp As Object Dim xlWkb As Object Dim xlSheet As Object Dim rCount As Long Set xlApp = CreateObject("excel.application.12") xlApp.Visible = True 'Open existing excel Set xlWkb = xlApp.Workbooks.Open("C:\pathtofile\QTYperday.xlsm") Set xlSheet = xlWkb.Sheets("Data") xlApp.Worksheets("Data").Activate 'Find the next empty line of the worksheet rCount = xlSheet.Range("A" & xlSheet.Rows.Count).End(-4162).Row rCount = rCount + 1 'Search all mail items in current mail directory For i = 1 To myfolder.Items.Count Set myItem = myfolder.Items(i) sender = myItem.SenderEmailAddress If sender = "[e-mail]" Then msgtext = myItem.Body TimeStamp = myItem.SentOn 'send the body of the mail message to the Function "onlyDigits" that will extract the numbers from it Dim myStr As String myStr = onlyDigits(msgtext) If myStr = "" Then myStr = "0" End If 'get the date from date time mailDateY = DatePart("yyyy", TimeStamp) ' get Year MailDateM = DatePart("m", TimeStamp) ' get Month MailDateD = DatePart("d", TimeStamp) ' get Day MailDateW = DatePart("w", TimeStamp) ' Get day of the week MailDate = (mailDateY & "/" & MailDateM & "/" & MailDateD) ' Combine it to be a date again 'set the day of the week If MailDateW = 1 Then MailDateW = "Sun" ElseIf MailDateW = 2 Then MailDateW = "Mon" ElseIf MailDateW = 3 Then MailDateW = "Tue" ElseIf MailDateW = 4 Then MailDateW = "Wed" ElseIf MailDateW = 5 Then MailDateW = "Thu" End If MailDay = MailDateW 'write to excel xlSheet.Range("A" & rCount).value = myStr xlSheet.Range("B" & rCount).value = MailDate xlSheet.Range("C" & rCount).value = MailDateW Else End If Next xlApp.Worksheets("Sheet2").Activate 'Rerash and Save the excel xlWkb.RefreshAll xlWkb.Save '************************ 'mail the chart to list * '************************ 'Here I need the code to get the graph from excel and paste it to the email 'as an excel object or picture, It does not matter 'next is sending the mail with the graph (as attachement?) Dim objMail As Outlook.MailItem Set objMail = Application.CreateItem(olMailItem) With objMail .To = "[e-mail]" .CC = "" .BCC = "" .Subject = "Subject Line" .Body = "Body of mail" .Attachments.Add 'What, how? .Send End With xlWkb.Close 1 xlApp.Quit ' Mark processed mail as Read and move it to RQ_done folder MoveItems2 End Sub --------------------------------------------------------------------------- Function onlyDigits(s As String) As String '************************************ '* extruct the number from the mail * '************************************ Dim retval As String ' This is the return string. ' Dim i As Integer ' Counter for character position. ' ' Initialise return string to empty ' retval = "" ' For every character in input string, copy digits to ' ' return string. ' For i = 1 To Len(s) If Mid(s, i, 1) >= "0" And Mid(s, i, 1) <= "9" Then retval = retval + Mid(s, i, 1) If retval = "" Then retval = "0" End If End If Next ' Then return the return string. ' onlyDigits = retval End Function 

我有这段代码在Excel上运行，它保存图表作为GIF文件附加并发送它，有没有办法将它从Outlook工作？

 Sub SaveSend_Embedded_Chart() 'Working in 2000-2016 'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm Dim OutApp As Object Dim OutMail As Object Dim Fname As String Set OutApp = CreateObject("Outlook.Application") Set OutMail = OutApp.CreateItem(0) 'File path/name of the gif file Fname = Environ$("temp") & "\My_Sales1.gif" 'Save Chart named "Chart 1" as gif file 'If you hold down the CTRL key when you select the chart 'in 2000-2013 you see the name in the Name box(formula bar) ActiveWorkbook.Worksheets("Sheet2").ChartObjects("Chart 3").Chart.Export _ Filename:=Fname, FilterName:="GIF" On Error Resume Next With OutMail .To = "[e-mail]" .CC = "" .BCC = "" .Subject = "This is the Subject line" .Body = "Hi there" .Attachments.Add Fname .Send 'or use .Display End With On Error GoTo 0 'Delete the gif file Kill Fname Set OutMail = Nothing Set OutApp = Nothing End Sub 

Answer 1

将Outlook对象replace为Excel对象，则无需在Outlook VBAmacros中创buildOutlook应用程序实例：

例

 Option Explicit Sub SaveSend_Embedded_Chart() Dim Fname As String Dim App As Excel.Application Dim xlBook As Excel.Workbook Dim FilePath As String Path = "C:\Temp\" FileName = "Temp.xlsx" On Error Resume Next Set App = GetObject(, "Excel.Application") If Err <> 0 Then Application.StatusBar = "Please wait while Excel source is opened ... " Set App = CreateObject("Excel.Application") xlStarted = True End If On Error GoTo 0 '// Open the workbook to input the data Set xlBook = App.Workbooks.Open(Path & FileName) 'File path/name of the gif file Fname = Environ$("temp") & "\My_Sales1.gif" 'Save Chart named "Chart 1" as gif file 'If you hold down the CTRL key when you select the chart 'in 2000-2013 you see the name in the Name box(formula bar) xlBook.Worksheets("Sheet2").ChartObjects("Chart 3").Chart.Export _ FileName:=Fname, FilterName:="GIF" With OutMail .To = "email@pcom" .CC = "" .BCC = "" .Subject = "This is the Subject line" .Body = "Hi there" .Attachments.Add Fname .Send 'or use .Display End With 'Delete the gif file Kill Fname xlBook.Close SaveChanges:=True If xlStarted Then App.Quit End If Set App = Nothing Set xlBook = Nothing End Sub 

Answer 2

你只需要像在Sub ProcessRequests()一样引用Excel对象

参见：

 Sub SaveSend_Embedded_Chart() 'Working in 2000-2016 'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm Dim OutApp As Object Dim OutMail As Object Dim Fname As String Set OutApp = CreateObject("Outlook.Application") Set OutMail = OutApp.CreateItem(0) 'File path/name of the gif file Fname = Environ$("temp") & "\My_Sales1.gif" Dim xlApp As Object Dim xlWkb As Object Dim xlSheet As Object Set xlApp = CreateObject("Excel.Application") xlApp.Visible = True 'Open existing excel file Set xlWkb = xlApp.Workbooks.Open("C:\pathtofile\QTYperday.xlsm") Set xlSheet = xlWkb.Sheets("Sheet2") 'Save Chart named "Chart 1" as gif file 'If you hold down the CTRL key when you select the chart 'in 2000-2013 you see the name in the Name box(formula bar) xlSheet.ChartObjects("Chart 3").Chart.Export _ FileName:=Fname, FilterName:="GIF" On Error Resume Next With OutMail .To = "[e-mail]" .CC = "" .BCC = "" .Subject = "This is the Subject line" .Body = "Hi there" .Attachments.Add Fname .Send 'or use .Display End With On Error GoTo 0 'Delete the gif file Kill Fname Set OutMail = Nothing Set OutApp = Nothing End Sub