如何使用Excel宏将图表和表格放在一封电子邮件中？ [英] How to put charts and tables in a single email using Excel Macro?
问题描述
我希望在运行时将图表和表格放在一封电子邮件中，它最终会在一封电子邮件中显示图表，并在另一封电子邮件中显示
表格。
这是我的代码：
Public Sub Insert_Charts_In_New_Email（）
Dim outApp As Object'Outlook.Application
Dim outMail As Object'Outlook.MailItem
Dim wEditor As Object'Word.Document
Dim wRange As Object'Word.Range
Dim chartsSheet As Object
Dim chartObj As ChartObject
Dim chartWidthCm As Single，chartHeightCm As Single
'电子邮件中所需的图表尺寸
chartWidthCm = 25.93
chartHeightCm = 16.95
'Sheet1包含图表
设置chartsSheet = ThisWorkbook.Sheets（" Defects"）
设置chartsSheet2 = ThisWorkbook.Sheets（" Test Execution
（Manual）"）
Set chartsSheet3 = ThisWorkbook.Sheets（" Aging
JIRAs"）
设置chartsSheet4 = ThisWorkbook.Sheets（" JIRA_List"）
设置chartsSheet5 = ThisWorkbook.Sheets（" Summary-Guidelines"）
设置outApp = CreateObject（" Outlook.Application"）
设置outMail = outApp.CreateItem（olMailItem）
outMail.Display
设置wEditor = outApp.ActiveInspector.WordEditor
设置wRange = wEditor.Application.ActiveDocument.Content
'确保后续插入和粘贴出现在
自动电子邮件签名之上
wRange.Collapse 1'方向：= wdCollapseStart
wRange.InsertAfter" Text at top"& vbNewLine
wRange.Collapse 0'方向：= wdCollapseEnd
设置chartObj = chartsSheet2.ChartObjects（" Chart
1"）
Insert_Resized_Chart chartObj，chartWidthCm，chartHeightCm，
wRange
wRange.InsertParagraphAfter
wRange.InsertAfter" Chart3"&
Time& vbNewLine
wRange.Collapse 0'方向：= wdCollapseEnd
'临时调整图表1并插入电子邮件
设置chartObj = chartsSheet.ChartObjects（" Chart
2"）
Insert_Resized_Chart chartObj，chartWidthCm，chartHeightCm，
wRange
wRange.InsertParagraphAfter
wRange.InsertAfter" Chart3"&
Time& vbNewLine
wRange.Collapse 0'方向：= wdCollapseEnd
设置chartObj = chartsSheet.ChartObjects（" Chart
3"）
Insert_Resized_Chart chartObj，chartWidthCm，chartHeightCm，
wRange
wRange.InsertParagraphAfter
wRange.InsertAfter" Chart3"&
Time& vbNewLine
wRange.Collapse 0'方向：= wdCollapseEnd
'临时调整图表2并插入电子邮件
设置chartObj = chartsSheet.ChartObjects（" Chart
1"）
Insert_Resized_Chart chartObj，chartWidthCm，chartHeightCm，
wRange
wRange.InsertParagraphAfter
wRange.InsertAfter" Chart3"&
Time& vbNewLine
wRange.Collapse 0'方向：= wdCollapseEnd
'临时调整图表3并插入电子邮件
'临时调整图表4并插入电子邮件
设置chartObj = chartsSheet3.ChartObjects（" Chart
1"）
Insert_Resized_Chart chartObj，chartWidthCm，chartHeightCm，
wRange
wRange.InsertParagraphAfter
wRange.InsertAfter" Chart1"&
Time& vbNewLine
wRange.Collapse 0'方向：= wdCollapseEnd
'复制感兴趣的范围
Dim r As Range
Dim r2 As Range
Dim r3 As Range
Dim r4 As Range
设置r = chartsSheet5.Range（" B3：F23"）
设置r2 = chartsSheet2.Range（" A57：L63"）
设置r3 = chartsSheet.Range（" A60：F63"）
设置r4 = chartsSheet4.Range（" A10：Q174"）
'打开一个新的邮件项目
设置outApp = CreateObject（" Outlook.Application"）
设置outMail = outApp.CreateItem（olMailItem）
'获取其Word编辑器
outMail.Display
设置wEditor = outApp.ActiveInspector.WordEditor
将此范围视为范围
r.Copy
wEditor.Range.PasteAndFormat wdChartPicture
r2.Copy
wEditor.Range（1，wEditor.Characters.Count）.PasteAndFormat
wdChartPicture
r3.Copy
wEditor.Range（2，wEditor.Characters.Count）.PasteAndFormat
wdChartPicture
r4.Copy
wEditor.Range（3，wEditor.Characters.Count）.PasteAndFormat
wdChartPicture
End Sub
Private Sub Insert_Resized_Chart（thisChartObject As
ChartObject，newWidthCm As Single，newHeightCm As Single，wordRange As Object）
'参数
'thisChartObject - 要调整大小的ChartObject
'newWidthCm - 以厘米为单位的新宽度
'newHeighCm - 以厘米为单位的新高度
'wordRange - 电子邮件中的当前位置，
a Word.Range对象
Dim chartShape As Shape
Dim currentWidth As Single
Dim currentHeight As Single
'将图表作为形状
设置chartShape = thisChartObject.Parent.Shapes（thisChartObject.Name）
'将图表更改为新尺寸
使用chartShape
currentWidth = .Width
currentHeight = .Height
。宽度= Application.CentimetersToPoints（newWidthCm）
.Height = Application.CentimetersToPoints（newHeightCm）
Debug.Print" Before：" ;; currentWidth; currentHeight，
" After：" ;; .Width; .Height
End With
'将图表插入电子邮件
thisChartObject.Chart.ChartArea.Copy
wordRange.PasteSpecial ,,, 4'DataType：= wdPasteBitmap
'恢复原始尺寸
使用chartShape
。宽度= currentWidth
.Height = currentHeight
End With
End Sub
Public Sub Insert_Charts_In_New_Email()
Dim outApp As Object 'Outlook.Application
Dim outMail As Object 'Outlook.MailItem
Dim wEditor As Object 'Word.Document
Dim wRange As Object 'Word.Range
Dim chartsSheet As Object
Dim chartObj As ChartObject
Dim chartWidthCm As Single, chartHeightCm As Single
'Required chart dimensions in the email
chartWidthCm = 25.93
chartHeightCm = 16.95
'Sheet1 contains the charts
Set chartsSheet = ThisWorkbook.Sheets("Defects")
Set chartsSheet2 = ThisWorkbook.Sheets("Test Execution
(Manual)")
Set chartsSheet3 = ThisWorkbook.Sheets("Ageing
JIRAs")
Set chartsSheet4 = ThisWorkbook.Sheets("JIRA_List")
Set chartsSheet5 = ThisWorkbook.Sheets("Summary-Guidelines")
Set outApp = CreateObject("Outlook.Application")
Set outMail = outApp.CreateItem(olMailItem)
outMail.Display
Set wEditor = outApp.ActiveInspector.WordEditor
Set wRange = wEditor.Application.ActiveDocument.Content
'Ensure subsequent inserts and pastes appear above
automatic email signature
wRange.Collapse 1 'Direction:=wdCollapseStart
wRange.InsertAfter "Text at top" & vbNewLine
wRange.Collapse 0 'Direction:=wdCollapseEnd
Set chartObj = chartsSheet2.ChartObjects("Chart
1")
Insert_Resized_Chart chartObj, chartWidthCm, chartHeightCm,
wRange
wRange.InsertParagraphAfter
wRange.InsertAfter "Text below Chart3 " &
Time & vbNewLine
wRange.Collapse 0 'Direction:=wdCollapseEnd
'Temporarily resize Chart 1 and insert in email
Set chartObj = chartsSheet.ChartObjects("Chart
2")
Insert_Resized_Chart chartObj, chartWidthCm, chartHeightCm,
wRange
wRange.InsertParagraphAfter
wRange.InsertAfter "Text below Chart3 " &
Time & vbNewLine
wRange.Collapse 0 'Direction:=wdCollapseEnd
Set chartObj = chartsSheet.ChartObjects("Chart
3")
Insert_Resized_Chart chartObj, chartWidthCm, chartHeightCm,
wRange
wRange.InsertParagraphAfter
wRange.InsertAfter "Text below Chart3 " &
Time & vbNewLine
wRange.Collapse 0 'Direction:=wdCollapseEnd
'Temporarily resize Chart 2 and insert in email
Set chartObj = chartsSheet.ChartObjects("Chart
1")
Insert_Resized_Chart chartObj, chartWidthCm, chartHeightCm,
wRange
wRange.InsertParagraphAfter
wRange.InsertAfter "Text below Chart3 " &
Time & vbNewLine
wRange.Collapse 0 'Direction:=wdCollapseEnd
'Temporarily resize Chart 3 and insert in email
'Temporarily resize Chart 4 and insert in email
Set chartObj = chartsSheet3.ChartObjects("Chart
1")
Insert_Resized_Chart chartObj, chartWidthCm, chartHeightCm,
wRange
wRange.InsertParagraphAfter
wRange.InsertAfter "Text below Chart1 " &
Time & vbNewLine
wRange.Collapse 0 'Direction:=wdCollapseEnd
'Copy range of interest
Dim r As Range
Dim r2 As Range
Dim r3 As Range
Dim r4 As Range
Set r = chartsSheet5.Range("B3:F23")
Set r2 = chartsSheet2.Range("A57:L63")
Set r3 = chartsSheet.Range("A60:F63")
Set r4 = chartsSheet4.Range("A10:Q174")
'Open a new mail item
Set outApp = CreateObject("Outlook.Application")
Set outMail = outApp.CreateItem(olMailItem)
'Get its Word editor
outMail.Display
Set wEditor = outApp.ActiveInspector.WordEditor
Dim thisRange As Range
r.Copy
wEditor.Range.PasteAndFormat wdChartPicture
r2.Copy
wEditor.Range(1, wEditor.Characters.Count).PasteAndFormat
wdChartPicture
r3.Copy
wEditor.Range(2, wEditor.Characters.Count).PasteAndFormat
wdChartPicture
r4.Copy
wEditor.Range(3, wEditor.Characters.Count).PasteAndFormat
wdChartPicture
End Sub
Private Sub Insert_Resized_Chart(thisChartObject As
ChartObject, newWidthCm As Single, newHeightCm As Single, wordRange As Object)
'Arguments
'thisChartObject - the ChartObject to be resized
'newWidthCm - new width in centimeters
'newHeighCm - new height in centimeters
'wordRange - the current position in the email, as
a Word.Range object
Dim chartShape As Shape
Dim currentWidth As Single
Dim currentHeight As Single
'Get the chart as a Shape
Set chartShape = thisChartObject.Parent.Shapes(thisChartObject.Name)
'Change chart to new dimensions
With chartShape
currentWidth = .Width
currentHeight = .Height
.Width = Application.CentimetersToPoints(newWidthCm)
.Height = Application.CentimetersToPoints(newHeightCm)
Debug.Print "Before: "; currentWidth; currentHeight,
"After: "; .Width; .Height
End With
'Insert chart into email
thisChartObject.Chart.ChartArea.Copy
wordRange.PasteSpecial , , , , 4 'DataType:=wdPasteBitmap
'Restore original dimensions
With chartShape
.Width = currentWidth
.Height = currentHeight
End With
End Sub
推荐答案
我无法调整表的大小，并且在运行时将图表和表放在一封电子邮件中，最终在一封电子邮件中显示图表
，在另一封电子邮件中显示表格。如何添加文本？
这里
是我的代码：
Public Sub Insert_Charts_In_New_Email（）
Dim outApp As Object'Outlook.Application
Dim outMail As Object'Outlook.MailItem
Dim wEditor As Object'Word.Document
Dim wRange As Object'Word.Range
Dim chartsSheet As Object
Dim chartObj As ChartObject
Dim chartWidthCm As Single，chartHeightCm As Single
'电子邮件中所需的图表尺寸
chartWidthCm = 25.93
chartHeightCm = 16.95
'Sheet1包含图表
设置chartsSheet = ThisWorkbook.Sheets（" Defects"）
设置chartsSheet2 = ThisWorkbook.Sheets（" Test Execution（Manual）"）
Set chartsSheet3 = ThisWorkbook.Sheets（" Aging JIRAs"）
设置chartsSheet4 = ThisWorkbook.Sheets（" JIRA_List"）
设置chartsSheet5 = ThisWorkbook.Sheets（" Summary-Guidelines"）
设置outApp = CreateObject（" Outlook.Application"）
设置outMail = outApp.CreateItem（olMailItem）
outMail.Display
设置wEditor = outApp.ActiveInspector.WordEditor
设置wRange = wEditor.Application.ActiveDocument.Content
'确保后续插入和粘贴显示在自动电子邮件签名上方
wRange.Collapse 1'方向：= wdCollapseStart
wRange.InsertAfter" Text at top"& vbNewLine
wRange.Collapse 0'方向：= wdCollapseEnd
设置chartObj = chartsSheet2.ChartObjects（" Chart 1"）
Insert_Resized_Chart chartObj，chartWidthCm，chartHeightCm，wRange
wRange.InsertParagraphAfter
wRange.InsertAfter "Text below Chart3 " & Time & vbNewLine
wRange.Collapse 0 ’Direction:=wdCollapseEnd
’Temporarily resize Chart 1 and insert in email
Set chartObj = chartsSheet.ChartObjects("Chart 2")
Insert_Resized_Chart chartObj, chartWidthCm, chartHeightCm, wRange
wRange.InsertParagraphAfter
wRange.InsertAfter "Text below Chart3 " & Time & vbNewLine
wRange.Collapse 0 ’Direction:=wdCollapseEnd
Set chartObj = chartsSheet.ChartObjects("Chart 3")
Insert_Resized_Chart chartObj, chartWidthCm, chartHeightCm, wRange
wRange.InsertParagraphAfter
wRange.InsertAfter "Text below Chart3 " & Time & vbNewLine
wRange.Collapse 0 ’Direction:=wdCollapseEnd
’Temporarily resize Chart 2 and insert in email
Set chartObj = chartsSheet.ChartObjects("Chart 1")
Insert_Resized_Chart chartObj, chartWidthCm, chartHeightCm, wRange
wRange.InsertParagraphAfter
wRange.InsertAfter "Text below Chart3 " & Time & vbNewLine
wRange.Collapse 0 ’Direction:=wdCollapseEnd
’Temporarily resize Chart 3 and insert in email
’Temporarily resize Chart 4 and insert in email
Set chartObj = chartsSheet3.ChartObjects("Chart 1")
Insert_Resized_Chart chartObj, chartWidthCm, chartHeightCm, wRange
wRange.InsertParagraphAfter
wRange.InsertAfter "Text below Chart1 " & Time & vbNewLine
wRange.Collapse 0 ’Direction:=wdCollapseEnd
’Copy range of interest
Dim r As Range
Dim r2 As Range
Dim r3 As Range
Dim r4 As Range
Set r = chartsSheet5.Range("B3:F23")
Set r2 = chartsSheet2.Range("A57:L63")
Set r3 = chartsSheet.Range("A60:F63")
Set r4 = chartsSheet4.Range("A10:Q174")
’Open a new mail item
Set outApp = CreateObject("Outlook.Application")
Set outMail = outApp.CreateItem(olMailItem)
’Get its Word editor
outMail.Display
Set wEditor = outApp.ActiveInspector.WordEditor
Dim thisRange As Range
r.Copy
wEditor.Range.PasteAndFormat wdChartPicture
r2.Copy
wEditor.Range(1, wEditor.Characters.Count).PasteAndFormat wdChartPicture
r3.Copy
wEditor.Range(2, wEditor.Characters.Count).PasteAndFormat wdChartPicture
r4.Copy
wEditor.Range(3, wEditor.Characters.Count).PasteAndFormat wdChartPicture
End Sub
Private Sub Insert_Resized_Chart(thisChartObject As ChartObject, newWidthCm As Single, newHeightCm As Single, wordRange As Object)
’Arguments
’thisChartObject - the ChartObject to be resized
’newWidthCm - new width in centimeters
’newHeighCm - new height in centimeters
’wordRange - the current position in the email, as a Word.Range object
Dim chartShape As Shape
Dim currentWidth As Single
Dim currentHeight As Single
’Get the chart as a Shape
Set chartShape = thisChartObject.Parent.Shapes(thisChartObject.Name)
’Change chart to new dimensions
With chartShape
currentWidth = .Width
currentHeight = .Height
.Width = Application.CentimetersToPoints(newWidthCm)
.Height = Application.CentimetersToPoints(newHeightCm)
Debug.Print "Before: "; currentWidth; currentHeight, "After: "; .Width; .Height
结束
’Insert chart into email
thisChartObject.Chart.ChartArea.Copy
wordRange.PasteSpecial , , , , 4 ’DataType:=wdPasteBitmap
’Restore original dimensions
With chartShape
.Width = currentWidth
.Height = currentHeight
结束
End Sub
Public Sub Insert_Charts_In_New_Email()
Dim outApp As Object 'Outlook.Application
Dim outMail As Object 'Outlook.MailItem
Dim wEditor As Object 'Word.Document
Dim wRange As Object 'Word.Range
Dim chartsSheet As Object
Dim chartObj As ChartObject
Dim chartWidthCm As Single, chartHeightCm As Single
'Required chart dimensions in the email
chartWidthCm = 25.93
chartHeightCm = 16.95
'Sheet1 contains the charts
Set chartsSheet = ThisWorkbook.Sheets("Defects")
Set chartsSheet2 = ThisWorkbook.Sheets("Test Execution (Manual)")
Set chartsSheet3 = ThisWorkbook.Sheets("Ageing JIRAs")
Set chartsSheet4 = ThisWorkbook.Sheets("JIRA_List")
Set chartsSheet5 = ThisWorkbook.Sheets("Summary-Guidelines")
Set outApp = CreateObject("Outlook.Application")
Set outMail = outApp.CreateItem(olMailItem)
outMail.Display
Set wEditor = outApp.ActiveInspector.WordEditor
Set wRange = wEditor.Application.ActiveDocument.Content
'Ensure subsequent inserts and pastes appear above automatic email signature
wRange.Collapse 1 'Direction:=wdCollapseStart
wRange.InsertAfter "Text at top" & vbNewLine
wRange.Collapse 0 'Direction:=wdCollapseEnd
Set chartObj = chartsSheet2.ChartObjects("Chart 1")
Insert_Resized_Chart chartObj, chartWidthCm, chartHeightCm, wRange
wRange.InsertParagraphAfter
wRange.InsertAfter "Text below Chart3 " & Time & vbNewLine
wRange.Collapse 0 'Direction:=wdCollapseEnd
'Temporarily resize Chart 1 and insert in email
Set chartObj = chartsSheet.ChartObjects("Chart 2")
Insert_Resized_Chart chartObj, chartWidthCm, chartHeightCm, wRange
wRange.InsertParagraphAfter
wRange.InsertAfter "Text below Chart3 " & Time & vbNewLine
wRange.Collapse 0 'Direction:=wdCollapseEnd
Set chartObj = chartsSheet.ChartObjects("Chart 3")
Insert_Resized_Chart chartObj, chartWidthCm, chartHeightCm, wRange
wRange.InsertParagraphAfter
wRange.InsertAfter "Text below Chart3 " & Time & vbNewLine
wRange.Collapse 0 'Direction:=wdCollapseEnd
'Temporarily resize Chart 2 and insert in email
Set chartObj = chartsSheet.ChartObjects("Chart 1")
Insert_Resized_Chart chartObj, chartWidthCm, chartHeightCm, wRange
wRange.InsertParagraphAfter
wRange.InsertAfter "Text below Chart3 " & Time & vbNewLine
wRange.Collapse 0 'Direction:=wdCollapseEnd
'Temporarily resize Chart 3 and insert in email
'Temporarily resize Chart 4 and insert in email
Set chartObj = chartsSheet3.ChartObjects("Chart 1")
Insert_Resized_Chart chartObj, chartWidthCm, chartHeightCm, wRange
wRange.InsertParagraphAfter
wRange.InsertAfter "Text below Chart1 " & Time & vbNewLine
wRange.Collapse 0 'Direction:=wdCollapseEnd
'Copy range of interest
Dim r As Range
Dim r2 As Range
Dim r3 As Range
Dim r4 As Range
Set r = chartsSheet5.Range("B3:F23")
Set r2 = chartsSheet2.Range("A57:L63")
Set r3 = chartsSheet.Range("A60:F63")
Set r4 = chartsSheet4.Range("A10:Q174")
'Open a new mail item
Set outApp = CreateObject("Outlook.Application")
Set outMail = outApp.CreateItem(olMailItem)
'Get its Word editor
outMail.Display
Set wEditor = outApp.ActiveInspector.WordEditor
Dim thisRange As Range
r.Copy
wEditor.Range.PasteAndFormat wdChartPicture
r2.Copy
wEditor.Range(1, wEditor.Characters.Count).PasteAndFormat wdChartPicture
r3.Copy
wEditor.Range(2, wEditor.Characters.Count).PasteAndFormat wdChartPicture
r4.Copy
wEditor.Range(3, wEditor.Characters.Count).PasteAndFormat wdChartPicture
End Sub
Private Sub Insert_Resized_Chart(thisChartObject As ChartObject, newWidthCm As Single, newHeightCm As Single, wordRange As Object)
'Arguments
'thisChartObject - the ChartObject to be resized
'newWidthCm - new width in centimeters
'newHeighCm - new height in centimeters
'wordRange - the current position in the email, as a Word.Range object
Dim chartShape As Shape
Dim currentWidth As Single
Dim currentHeight As Single
'Get the chart as a Shape
Set chartShape = thisChartObject.Parent.Shapes(thisChartObject.Name)
'Change chart to new dimensions
With chartShape
currentWidth = .Width
currentHeight = .Height
.Width = Application.CentimetersToPoints(newWidthCm)
.Height = Application.CentimetersToPoints(newHeightCm)
Debug.Print "Before: "; currentWidth; currentHeight, "After: "; .Width; .Height
End With
'Insert chart into email
thisChartObject.Chart.ChartArea.Copy
wordRange.PasteSpecial , , , , 4 'DataType:=wdPasteBitmap
'Restore original dimensions
With chartShape
.Width = currentWidth
.Height = currentHeight
End With
End Sub
这篇关于如何使用Excel宏将图表和表格放在一封电子邮件中？的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！
