如何从 Outlook 宏发送 Excel 图表
How to send an Excel chart from outlook macro
我已经到了 运行 带有规则和警报的 outlook 宏的地步。
宏在收件箱中搜索来自邮件地址的邮件，找到后将其移动到子文件夹，然后从邮件正文中仅提取号码，打开一个Excel，粘贴编号和邮件日期到下一个空闲行的 Excel，更新 Excel，保存并关闭它。
最后它将邮件移动到 DONE 目录并将其标记为已读。
在 Excel 中有一个创建图表（图表 3）的枢轴 table。
现在我想将该图表从 excel 发送给邮件收件人，
我找到了很多从 Excel 但不是从 outlook macro 邮寄图表的方法。
这是我目前的情况：
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] = 'mail@domain.com'")
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] = 'mail@domain.com'")
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 = "mail@domain.com" 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 = "me@email.com"
.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 = "eeee@eeee.com"
.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
您只需像在 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 = "eitan@pitkit.co.il"
.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
将 Outlook 对象替换为 Excel 对象，无需在 Outlook VBA 宏中创建 Outlook 应用程序实例：
例子
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
我已经到了 运行 带有规则和警报的 outlook 宏的地步。
宏在收件箱中搜索来自邮件地址的邮件，找到后将其移动到子文件夹，然后从邮件正文中仅提取号码，打开一个Excel，粘贴编号和邮件日期到下一个空闲行的 Excel，更新 Excel，保存并关闭它。
最后它将邮件移动到 DONE 目录并将其标记为已读。
在 Excel 中有一个创建图表（图表 3）的枢轴 table。
现在我想将该图表从 excel 发送给邮件收件人， 我找到了很多从 Excel 但不是从 outlook macro 邮寄图表的方法。
这是我目前的情况：
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] = 'mail@domain.com'")
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] = 'mail@domain.com'")
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 = "mail@domain.com" 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 = "me@email.com"
.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 = "eeee@eeee.com"
.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
您只需像在 Sub ProcessRequests()
参见：
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 = "eitan@pitkit.co.il"
.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
将 Outlook 对象替换为 Excel 对象，无需在 Outlook VBA 宏中创建 Outlook 应用程序实例：
例子
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