从 Excel-VBA 创建电子邮件以包含带条件格式的范围
Create email from Excel-VBA to include Range with Conditional Formatting
背景：
我仔细研究并学会了根据 Rob de Bruin's guide 创建电子邮件，此处 "RDB"。在尝试使我的电子邮件内容合适时，我发现 RDB 创建的 RangetoHTM 函数不维护通过 conditional formatting.
应用的颜色
我尝试了建议的变通方法，更改现有代码以包含 .Cells(1).PasteSpecial xlPasteAllUsingSourceTheme（建议 here），但似乎也无法解决问题。
我试图继续使用 SendKeys，但我无法让 "^V" 工作，希望有另一种方法可以做到这一点。我已经尝试过并手动 Ctrl+V 并且没有可粘贴的内容，尽管 spreadsheet 已经概述了选定的范围。
问题：
从 Excel 复制范围时，它具有基本颜色以及条件格式的附加颜色，我无法通过代码将所需范围粘贴到 Outlook 电子邮件中，因为条件格式颜色已被删除.
制作范围的图像 (png) 是不可接受的输出，因为在要粘贴的范围的一列中需要遵循链接。
问题：
如有其他建议，我们将不胜感激，尽管这会使这篇文章成为一个主观的讨论文章，对于 Whosebug 来说太宽泛了……所以我将尽量针对我的代码 created/modified。
如果有人知道如何修改 RDB 的代码以允许条件格式的单元格，那也很棒。
考虑到我正在尝试 SendKeys，有人知道为什么我无法让粘贴起作用吗？
有问题的代码：
注意：我不得不乱用模块名称并删除一些内容（标准），所以请原谅被调用的私有 subs 上不太具体的标签。以下代码中有五 (5) 个子例程和一 (1) 个函数，顺序为：
Public sub execute() '按首选顺序调用私有sub的那个
Private Sub SheetVals() '设置 excel sheet 中的范围和值变量
Private Sub MsgContent() ' 创建电子邮件并使用 sheet vals
Private Sub SetToNothing() '设置 blah = nothing
Private Function CopyRangeToHTML(ByVal name As Range) 'RDB的代码
Private Sub send_keys_test() '我一直在尝试发送密钥
.
Option Explicit
Private i As Long, legendrng As Range, tablerng As Range, mval As String, sdate As String, bmonth As String, bdate As String
Private msg As Outlook.MailItem, oapp As Outlook.Application
Public Sub execute()
If ActiveSheet.name <> "NAME" Then Exit Sub
With Application
.ScreenUpdating = False
.DisplayAlerts = False
.Calculation = xlManual
End With
'''
SheetVals
MsgContent
send_keys_test 'Very bottom of the code
SetToNothing
'''
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.Calculation = xlAutomatic
End With
End Sub
Private Sub SheetVals()
Dim lrtable As Long, lrlegend As Long, lc As Long
With Sheets("Name")
lc = 9
lrlegend = .Cells(.Rows.Count, 1).End(xlUp).Row
lrtable = .Cells(.Rows.Count, lc).End(xlUp).Row
Set legendrng = .Range(.Cells(lrlegend - 4, 1), .Cells(lrlegend, 1))
Set tablerng = .Range(.Cells(3, 1), .Cells(lrtable, lc))
mval = Format(.Cells(.Columns(1).Find(What:="Shalom", LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False).Row + 3, 6).Value, "$#,###")
sdate = Format(Date, "yyyyMMMdd")
bmonth = Format(Date, "MMM")
bdate = Format(Date, "MMM dd, yyyy")
End With
End Sub
Private Sub MsgContent()
Set oapp = CreateObject("Outlook.Application")
Set msg = oapp.CreateItem(olMailItem)
With msg
.Display
.Importance = 2
.to = ""
.Subject = "Subject " & sdate
.HTMLBody = _
"<HTML><body>Content.<br></body></HTML>"
'.HTMLBody = .Body & CopyRangeToHTML(tablerng)
.Attachments.Add ActiveWorkbook.FullName
End With
End Sub
Private Sub SetToNothing()
Set msg = Nothing
Set oapp = Nothing
i = 0
Set legendrng = Nothing
Set tablerng = Nothing
mval = ""
sdate = ""
bmonth = ""
bdate = ""
End Sub
Private Function CopyRangeToHTML(ByVal name As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
Dim fso As Object, ts As Object, TempFile As String, 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
name.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)
CopyRangeToHTML = ts.ReadAll
ts.Close
CopyRangeToHTML = Replace(CopyRangeToHTML, "align=center x:publishsource=", "align=left x:publishsource=")
'Close TempWB
TempWB.Close savechanges:=False
'Delete the htm file we used in this function
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
Private Sub send_keys_test()
'comments out the .HTMLBody section of task_two with this being the test
msg.GetInspector.Activate
SendKeys "{Tab}{Tab}{Tab}{Tab}{Tab}", True
SendKeys "^{End}", True
tablerng.Copy
msg.GetInspector.Activate
SendKeys "^V", True
End Sub
编辑 1: + 编辑 2:
用这段代码测试发送键，我去掉了上面的大部分代码，专注于复制所需的范围。这似乎没有复制，因为 Excel 中的复制范围没有显示复制信号（范围的闪烁轮廓），也没有手动按 ctrl+V 将任何内容粘贴到 Word 或 Outlook 中：
Option Explicit
Private tablerng As Range
Private Sub fdsa()
Set tablerng = Range(Cells(3, 1), Cells(47, 9))
tablerng.Select
Application.SendKeys "^c", True 'Edit2: Once i added "Application." sendkeys worked for me
End Sub
因此，由于 Application.，我可以使用发送键，但尽管 copy/paste，条件格式仍然存在问题。嗯...将添加一些图像，在条件格式之前和之后...
之前： After:
当通过 RDB rangetohtml 方法 copy/pasting 到 Outlook 时，条件格式添加的蓝色会丢失。
您不应该求助于 SendKeys。对 "RDB" 稍作更改，以便 'PasteAll' 和条件格式似乎可以正常传输。下面是一个非常精简的例子（假设你在单元格中有条件格式 A1:B10）
Sub CreateEmail()
Dim oApp As Object: Set oApp = CreateObject("Outlook.Application")
Dim oMail As Object: Set oMail = oApp.CreateItem(olMailItem)
Dim wsData As Worksheet: Set wsData = ThisWorkbook.Worksheets("Sheet1")
Dim rData As Range: Set rData = wsData.Range("A1:B10")
With oMail
.To = "Test"
.HTMLBody = _
"<HTML><body>Content.<br></body></HTML>"
.HTMLBody = .HTMLBody & RangetoHTML(rData)
.Display
End With
End Sub
Function RangetoHTML(rng As Range)
' By Ron de Bruin.
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
Application.ScreenUpdating = False
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial xlPasteAll
.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=")
'Close TempWB
TempWB.Close savechanges:=False
Application.ScreenUpdating = True
'Delete the htm file we used in this function
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
********* 编辑 *********
不确定为什么它对您不起作用。我测试了条件格式并将更改后的单元格复制到 e-mail.
RangetoHTML 函数可能是可编辑的，以消除将范围复制和粘贴到新书的需要[希望绕过问题，因为它会使用直接来源]（我目前在没有 Outlook 的 PC 上所以无法测试我修改过的代码）。请随时尝试一下，看看它是否有效。
Function RangetoHTML(rng As Range)
' Altered from code by Ron de Bruin.
Dim fso As Object, ts As Object
Dim TempFile As String
Dim wbSrc As Workbook: Set wbSrc = rng.Worksheet.Parent
TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
'Publish the sheet range to a htm file
With wbSrc.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=rng.Worksheet.Name, _
Source:=rng.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=")
'Delete the htm file we used in this function
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set wbSrc = Nothing
End Function
由于知道 .Paragraphs(.Paragraphs.Count).Range.PasteExcelTable False, False, False 存在于 MS Word 中，因此我最终做了更多的努力来解决这个问题。
这是一个麻烦的解决方法，尽管我在将其称为最终产品之前尝试使用 Tragamor 的解决方案……它有效，但并不漂亮。
Private Sub task_two()
Set wApp = CreateObject("Word.Application")
Set doc = wApp.Documents.Add
With doc
.content.InsertAfter "Content" & vbNewLine & vbNewLine
wApp.Selection.EndKey unit:=wdStory, Extend:=wdMove
tablerng.Copy
.Paragraphs(.Paragraphs.Count).Range.PasteExcelTable False, False, False
End With
End Sub
Private Sub task_three()
Set oApp = CreateObject("Outlook.Application")
Set msg = oApp.CreateItem(olMailItem)
doc.content.Copy
With msg
.Display
.Importance = 2
.To = ""
.Subject = "Subject " & sdate
.GetInspector.WordEditor.content.Paste
.Attachments.Add ActiveWorkbook.FullName
End With
End Sub
Private Sub task_four()
doc.Close SaveChanges:=wdDoNotSaveChanges
Set doc = Nothing
wApp.Quit
Set wApp = Nothing
Set msg = Nothing
Set oApp = Nothing
i = 0
Set legendrng = Nothing
Set tablerng = Nothing
mval = ""
sdate = ""
bmonth = ""
bdate = ""
End Sub
背景：
我仔细研究并学会了根据 Rob de Bruin's guide 创建电子邮件，此处 "RDB"。在尝试使我的电子邮件内容合适时，我发现 RDB 创建的 RangetoHTM 函数不维护通过 conditional formatting.
我尝试了建议的变通方法，更改现有代码以包含 .Cells(1).PasteSpecial xlPasteAllUsingSourceTheme（建议 here），但似乎也无法解决问题。
我试图继续使用 SendKeys，但我无法让 "^V" 工作，希望有另一种方法可以做到这一点。我已经尝试过并手动 Ctrl+V 并且没有可粘贴的内容，尽管 spreadsheet 已经概述了选定的范围。
问题：
从 Excel 复制范围时，它具有基本颜色以及条件格式的附加颜色，我无法通过代码将所需范围粘贴到 Outlook 电子邮件中，因为条件格式颜色已被删除.
制作范围的图像 (png) 是不可接受的输出，因为在要粘贴的范围的一列中需要遵循链接。
问题：
如有其他建议，我们将不胜感激，尽管这会使这篇文章成为一个主观的讨论文章，对于 Whosebug 来说太宽泛了……所以我将尽量针对我的代码 created/modified。
如果有人知道如何修改 RDB 的代码以允许条件格式的单元格，那也很棒。
考虑到我正在尝试 SendKeys，有人知道为什么我无法让粘贴起作用吗？
有问题的代码：
注意：我不得不乱用模块名称并删除一些内容（标准），所以请原谅被调用的私有 subs 上不太具体的标签。以下代码中有五 (5) 个子例程和一 (1) 个函数，顺序为：
Public sub execute() '按首选顺序调用私有sub的那个
Private Sub SheetVals() '设置 excel sheet 中的范围和值变量
Private Sub MsgContent() ' 创建电子邮件并使用 sheet vals
Private Sub SetToNothing() '设置 blah = nothing
Private Function CopyRangeToHTML(ByVal name As Range) 'RDB的代码
Private Sub send_keys_test() '我一直在尝试发送密钥
.
Option Explicit
Private i As Long, legendrng As Range, tablerng As Range, mval As String, sdate As String, bmonth As String, bdate As String
Private msg As Outlook.MailItem, oapp As Outlook.Application
Public Sub execute()
If ActiveSheet.name <> "NAME" Then Exit Sub
With Application
.ScreenUpdating = False
.DisplayAlerts = False
.Calculation = xlManual
End With
'''
SheetVals
MsgContent
send_keys_test 'Very bottom of the code
SetToNothing
'''
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.Calculation = xlAutomatic
End With
End Sub
Private Sub SheetVals()
Dim lrtable As Long, lrlegend As Long, lc As Long
With Sheets("Name")
lc = 9
lrlegend = .Cells(.Rows.Count, 1).End(xlUp).Row
lrtable = .Cells(.Rows.Count, lc).End(xlUp).Row
Set legendrng = .Range(.Cells(lrlegend - 4, 1), .Cells(lrlegend, 1))
Set tablerng = .Range(.Cells(3, 1), .Cells(lrtable, lc))
mval = Format(.Cells(.Columns(1).Find(What:="Shalom", LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False).Row + 3, 6).Value, "$#,###")
sdate = Format(Date, "yyyyMMMdd")
bmonth = Format(Date, "MMM")
bdate = Format(Date, "MMM dd, yyyy")
End With
End Sub
Private Sub MsgContent()
Set oapp = CreateObject("Outlook.Application")
Set msg = oapp.CreateItem(olMailItem)
With msg
.Display
.Importance = 2
.to = ""
.Subject = "Subject " & sdate
.HTMLBody = _
"<HTML><body>Content.<br></body></HTML>"
'.HTMLBody = .Body & CopyRangeToHTML(tablerng)
.Attachments.Add ActiveWorkbook.FullName
End With
End Sub
Private Sub SetToNothing()
Set msg = Nothing
Set oapp = Nothing
i = 0
Set legendrng = Nothing
Set tablerng = Nothing
mval = ""
sdate = ""
bmonth = ""
bdate = ""
End Sub
Private Function CopyRangeToHTML(ByVal name As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
Dim fso As Object, ts As Object, TempFile As String, 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
name.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)
CopyRangeToHTML = ts.ReadAll
ts.Close
CopyRangeToHTML = Replace(CopyRangeToHTML, "align=center x:publishsource=", "align=left x:publishsource=")
'Close TempWB
TempWB.Close savechanges:=False
'Delete the htm file we used in this function
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
Private Sub send_keys_test()
'comments out the .HTMLBody section of task_two with this being the test
msg.GetInspector.Activate
SendKeys "{Tab}{Tab}{Tab}{Tab}{Tab}", True
SendKeys "^{End}", True
tablerng.Copy
msg.GetInspector.Activate
SendKeys "^V", True
End Sub
编辑 1: + 编辑 2:
用这段代码测试发送键，我去掉了上面的大部分代码，专注于复制所需的范围。这似乎没有复制，因为 Excel 中的复制范围没有显示复制信号（范围的闪烁轮廓），也没有手动按 ctrl+V 将任何内容粘贴到 Word 或 Outlook 中：
Option Explicit
Private tablerng As Range
Private Sub fdsa()
Set tablerng = Range(Cells(3, 1), Cells(47, 9))
tablerng.Select
Application.SendKeys "^c", True 'Edit2: Once i added "Application." sendkeys worked for me
End Sub
因此，由于 Application.，我可以使用发送键，但尽管 copy/paste，条件格式仍然存在问题。嗯...将添加一些图像，在条件格式之前和之后...
之前：
当通过 RDB rangetohtml 方法 copy/pasting 到 Outlook 时，条件格式添加的蓝色会丢失。
您不应该求助于 SendKeys。对 "RDB" 稍作更改，以便 'PasteAll' 和条件格式似乎可以正常传输。下面是一个非常精简的例子（假设你在单元格中有条件格式 A1:B10）
Sub CreateEmail()
Dim oApp As Object: Set oApp = CreateObject("Outlook.Application")
Dim oMail As Object: Set oMail = oApp.CreateItem(olMailItem)
Dim wsData As Worksheet: Set wsData = ThisWorkbook.Worksheets("Sheet1")
Dim rData As Range: Set rData = wsData.Range("A1:B10")
With oMail
.To = "Test"
.HTMLBody = _
"<HTML><body>Content.<br></body></HTML>"
.HTMLBody = .HTMLBody & RangetoHTML(rData)
.Display
End With
End Sub
Function RangetoHTML(rng As Range)
' By Ron de Bruin.
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
Application.ScreenUpdating = False
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial xlPasteAll
.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=")
'Close TempWB
TempWB.Close savechanges:=False
Application.ScreenUpdating = True
'Delete the htm file we used in this function
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
********* 编辑 *********
不确定为什么它对您不起作用。我测试了条件格式并将更改后的单元格复制到 e-mail.
RangetoHTML 函数可能是可编辑的，以消除将范围复制和粘贴到新书的需要[希望绕过问题，因为它会使用直接来源]（我目前在没有 Outlook 的 PC 上所以无法测试我修改过的代码）。请随时尝试一下，看看它是否有效。
Function RangetoHTML(rng As Range)
' Altered from code by Ron de Bruin.
Dim fso As Object, ts As Object
Dim TempFile As String
Dim wbSrc As Workbook: Set wbSrc = rng.Worksheet.Parent
TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
'Publish the sheet range to a htm file
With wbSrc.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=rng.Worksheet.Name, _
Source:=rng.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=")
'Delete the htm file we used in this function
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set wbSrc = Nothing
End Function
由于知道 .Paragraphs(.Paragraphs.Count).Range.PasteExcelTable False, False, False 存在于 MS Word 中，因此我最终做了更多的努力来解决这个问题。
这是一个麻烦的解决方法，尽管我在将其称为最终产品之前尝试使用 Tragamor 的解决方案……它有效，但并不漂亮。
Private Sub task_two()
Set wApp = CreateObject("Word.Application")
Set doc = wApp.Documents.Add
With doc
.content.InsertAfter "Content" & vbNewLine & vbNewLine
wApp.Selection.EndKey unit:=wdStory, Extend:=wdMove
tablerng.Copy
.Paragraphs(.Paragraphs.Count).Range.PasteExcelTable False, False, False
End With
End Sub
Private Sub task_three()
Set oApp = CreateObject("Outlook.Application")
Set msg = oApp.CreateItem(olMailItem)
doc.content.Copy
With msg
.Display
.Importance = 2
.To = ""
.Subject = "Subject " & sdate
.GetInspector.WordEditor.content.Paste
.Attachments.Add ActiveWorkbook.FullName
End With
End Sub
Private Sub task_four()
doc.Close SaveChanges:=wdDoNotSaveChanges
Set doc = Nothing
wApp.Quit
Set wApp = Nothing
Set msg = Nothing
Set oApp = Nothing
i = 0
Set legendrng = Nothing
Set tablerng = Nothing
mval = ""
sdate = ""
bmonth = ""
bdate = ""
End Sub