向邮件添加快照

时间：2014-03-17 12:00:08

标签： vba outlook outlook-vba

此代码自动下载附件，然后在计算发送新邮件后附带附件。

我想在邮件中添加快照。它显示一个错误，HTML代码将粘贴在正文中。错误在RangetoHTML（rng）中。

Public Sub ExportFile13314(MyMail As MailItem)
Dim outNS As Outlook.NameSpace
Dim outFolder As Outlook.MAPIFolder
Dim outNewMail As Outlook.MailItem
Dim strDir As String

Set outNS = GetNamespace("MAPI")
Set outFolder = outNS.GetDefaultFolder(olFolderInbox).Folders("Network Critical Report")

Set outNewMail = outFolder.Items.GetLast
strDir = "C:\Users\soumyajitd\Desktop\Network Critical Report\"
If outNewMail.Attachments.count = 0 Then GoTo Err
outNewMail.Attachments(1).SaveAsFile strDir & "Network_Critical_Report.csv"

Dim xlApp As Excel.Application

Dim wbTarget As Excel.Workbook 'Test
Dim wsTarget1 As Excel.Worksheet
Dim wsTarget2 As Excel.Worksheet
Dim wsTarget3 As Excel.Worksheet

Dim wbThis As Excel.Workbook 'Network_Critical_Report.csv
Dim wsThis As Excel.Worksheet

Dim OpenAlarms As Excel.Workbook 'Final Mail attachment
Dim RawData1 As Excel.Worksheet
Dim SnapshotSite As Excel.Worksheet
Dim SnapshotBSC As Excel.Worksheet
Dim pt As Excel.PivotTable

Dim strName  As String   'name of the source sheet/ target workbook

Set xlApp = New Excel.Application
xlApp.DisplayAlerts = False

'xlApp.Workbooks.Open strDir & "Network_Critical_Report.csv"
'xlApp.Workbooks.Open strDir & "Test.xlsx"
Set wbThis = xlApp.Workbooks.Open("C:\Users\soumyajitd\Desktop\Network Critical    Report\Network_Critical_Report.csv")
Set wsThis = wbThis.Worksheets("Network_Critical_Report")

Set wbTarget = xlApp.Workbooks.Open("C:\Users\soumyajitd\Desktop\Network Critical Report\Test.xlsx")
Set wsTarget1 = wbTarget.Worksheets("Raw_Data")
Set wsTarget2 = wbTarget.Worksheets("Snapshot(Sitewise ageing)")
Set wsTarget3 = wbTarget.Worksheets("Snapshot(BSC wise count)")
Set pt = wsTarget3.PivotTables("PivotTable2")

Set OpenAlarms = xlApp.Workbooks.Open("C:\Users\soumyajitd\Desktop\Network Critical Report\Open_Alarms.xlsx")
Set RawData1 = OpenAlarms.Worksheets("Raw_Data1")
Set SnapshotSite = OpenAlarms.Worksheets("Snapshot(Sitewise ageing)1")
Set SnapshotBSC = OpenAlarms.Worksheets("Snapshot(BSC wise count)1")

'select cell A1 on the target book
'clear existing values form target book
wsTarget1.UsedRange.ClearContents
'activate the source book
wbThis.Activate
xlApp.CutCopyMode = False
'copy the range from source book
wsThis.UsedRange.Copy
'paste the data on the target book
wsTarget1.Range("A1").PasteSpecial Paste:=xlPasteValues
'save the target book
pt.RefreshTable
wbTarget.Save
'close the workbook

RawData1.UsedRange.ClearContents
SnapshotSite.UsedRange.ClearContents
SnapshotBSC.UsedRange.ClearContents

wbTarget.Activate
xlApp.CutCopyMode = False
wsTarget1.UsedRange.Copy
RawData1.Range("A1").PasteSpecial Paste:=xlPasteValues

xlApp.CutCopyMode = False
wsTarget2.UsedRange.Copy
SnapshotSite.Range("A1").PasteSpecial Paste:=xlPasteValues

xlApp.CutCopyMode = False
wsTarget3.UsedRange.Copy
SnapshotBSC.Range("A1").PasteSpecial Paste:=xlPasteValues

OpenAlarms.Save

'#############################################################

Dim rng As Range
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook

Set excelApp = New Excel.Application

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
Set rng = SnapshotBSC.Range("y4:z35")

rng.Copy

Set TempWB = Workbooks.Add(1)

With TempWB.Sheets(1)
    .Cells(1).PasteSpecial Paste:=8        ' Paste over column widths from the file
    .Cells(1).PasteSpecial xlPasteValues
    .Cells(1).PasteSpecial xlPasteFormats
    .Cells(1).Select
    excelApp.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=")

'################################################################

Dim objMsg As MailItem
Dim ToRecipient As Variant
Dim ccRecipient As Variant
Dim Subject As String
Dim Body As String

Dim FilePathtoAdd As String

Set objMsg = Application.CreateItem(olMailItem)

objMsg.To = "soumyajit.dutta@icloud.com"
objMsg.CC = "soumyajit.dutta@hotmail.com"

objMsg.Subject = "Open_Alarm_Report"
objMsg.BodyFormat = olFormatHTML

objMsg.HTMLBody = "Hi," & vbNewLine & _
                vbNewLine & _
                "PFA Network Open Alarm Report." & " " & RangetoHTML(rng) & vbNewLine & _
                vbNewLine & _
                "Regards."

objMsg.Attachments.Add "C:\Users\soumyajitd\Desktop\Network Critical Report\Open_Alarms.xlsx"

objMsg.Send

 '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

wbTarget.Close
wbThis.Close
OpenAlarms.Close

xlApp.CutCopyMode = False
Kill ("C:\Users\soumyajitd\Desktop\Network Critical Report\Network_Critical_Report.csv")
'clear memory
Set wbTarget = Nothing
Set wbThis = Nothing
Set xlApp = Nothing
Set outNewMail = Nothing
Set outFolder = Nothing
Set outNS = Nothing
Err:
Set outFolder = Nothing
Set OuNewMail = Nothing
Set outNS = Nothing

End Function

1 个答案:

答案 0 :(得分：0)

经过一些修修补补后，我设法自己做了。 This帖子对我帮助很大。

错误即将发生，因为我没有正确地声明RangetoHTML（rng）。现在最后的代码是：

Public Sub ExportFile13314(MyMail As MailItem)
Dim outNS As Outlook.NameSpace
Dim outFolder As Outlook.MAPIFolder
Dim outNewMail As Outlook.MailItem
Dim strDir As String

Set outNS = GetNamespace("MAPI")
Set outFolder = outNS.GetDefaultFolder(olFolderInbox).Folders("Network Critical Report")

Set outNewMail = outFolder.Items.GetLast
strDir = "C:\Users\soumyajitd\Desktop\Network Critical Report\"
If outNewMail.Attachments.count = 0 Then GoTo Err
outNewMail.Attachments(1).SaveAsFile strDir & "Network_Critical_Report.csv"


Dim xlApp As Excel.Application

Dim wbTarget As Excel.Workbook 'Test
Dim wsTarget1 As Excel.Worksheet
Dim wsTarget2 As Excel.Worksheet
Dim wsTarget3 As Excel.Worksheet

Dim wbThis As Excel.Workbook 'Network_Critical_Report.csv
Dim wsThis As Excel.Worksheet

Dim OpenAlarms As Excel.Workbook 'Final Mail attachment
Dim RawData1 As Excel.Worksheet
Dim SnapshotSite As Excel.Worksheet
Dim SnapshotBSC As Excel.Worksheet
Dim pt As Excel.PivotTable

Dim strName  As String   'name of the source sheet/ target workbook
Set xlApp = New Excel.Application
xlApp.DisplayAlerts = False


'xlApp.Workbooks.Open strDir & "Network_Critical_Report.csv"
'xlApp.Workbooks.Open strDir & "Test.xlsx"
Set wbThis = xlApp.Workbooks.Open("C:\Users\soumyajitd\Desktop\Network Critical Report\Network_Critical_Report.csv")
Set wsThis = wbThis.Worksheets("Network_Critical_Report")

Set wbTarget = xlApp.Workbooks.Open("C:\Users\soumyajitd\Desktop\Network Critical Report\Test.xlsx")
Set wsTarget1 = wbTarget.Worksheets("Raw_Data")
Set wsTarget2 = wbTarget.Worksheets("Snapshot(Sitewise ageing)")
Set wsTarget3 = wbTarget.Worksheets("Snapshot(BSC wise count)")
Set pt = wsTarget3.PivotTables("PivotTable2")


Set OpenAlarms = xlApp.Workbooks.Open("C:\Users\soumyajitd\Desktop\Network Critical Report\Open_Alarms.xlsx")
Set RawData1 = OpenAlarms.Worksheets("Raw_Data1")
Set SnapshotSite = OpenAlarms.Worksheets("Snapshot(Sitewise ageing)1")
Set SnapshotBSC = OpenAlarms.Worksheets("Snapshot(BSC wise count)1")

'select cell A1 on the target book
'clear existing values form target book
wsTarget1.UsedRange.ClearContents
'activate the source book
wbThis.Activate
xlApp.CutCopyMode = False
'copy the range from source book
wsThis.UsedRange.Copy
'paste the data on the target book
wsTarget1.Range("A1").PasteSpecial Paste:=xlPasteValues
'save the target book
pt.RefreshTable
wbTarget.Save
'close the workbook

RawData1.UsedRange.ClearContents
SnapshotSite.UsedRange.ClearContents
SnapshotBSC.UsedRange.ClearContents

wbTarget.Activate
xlApp.CutCopyMode = False
wsTarget1.UsedRange.Copy
RawData1.Range("A1").PasteSpecial Paste:=xlPasteValues

xlApp.CutCopyMode = False
wsTarget2.UsedRange.Copy
SnapshotSite.Range("A1").PasteSpecial Paste:=xlPasteValues

xlApp.CutCopyMode = False
wsTarget3.UsedRange.Copy
SnapshotBSC.Range("A1").PasteSpecial Paste:=xlPasteValues

OpenAlarms.Save

p1 = RangetoHTML(SnapshotBSC.Range("y4:z35"))

Dim objMsg As MailItem
Dim ToRecipient As Variant
Dim ccRecipient As Variant
Dim Subject As String
Dim Body As String

Dim FilePathtoAdd As String
Set objMsg = Application.CreateItem(olMailItem)



objMsg.To = "name@domain.com"
objMsg.CC = "name@domain.com"



objMsg.Subject = "Open_Alarm_Report"


objMsg.HTMLBody = "Hi," & "<br><br>" & vbNewLine & _
                vbNewLine & _
                vbNewLine & _
                "PFA Network Open Alarm Report." & "<br><br>" & vbNewLine & _
                p1 & " " & vbNewLine & _
                "<br><br>" & vbNewLine & _
                vbNewLine & _
                "Regards." & vbNewLine & _
                "<br>" & vbNewLine & _
                "Soumyajit Dutta" & vbNewLine & _
                "<br>" & vbNewLine & _
                "Mob - 9836733712"




 objMsg.Attachments.Add "C:\Users\soumyajitd\Desktop\Network Critical Report\Open_Alarms.xlsx"


 objMsg.Send



Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing

wbTarget.Close
wbThis.Close
OpenAlarms.Close

xlApp.CutCopyMode = False
Kill ("C:\Users\soumyajitd\Desktop\Network Critical Report\Network_Critical_Report.csv")
'clear memory
Set wbTarget = Nothing
Set wbThis = Nothing
Set xlApp = Nothing
Set outNewMail = Nothing
Set outFolder = Nothing
Set outNS = Nothing
Err:
Set outFolder = Nothing
Set OuNewMail = Nothing
Set outNS = Nothing


End Sub

'#############################################################


Function RangetoHTML(rng As Range)


Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook


Set excelApp = New Excel.Application

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        ' Paste over column widths from the file
    .Cells(1).PasteSpecial xlPasteValues
    .Cells(1).PasteSpecial xlPasteFormats
    .Cells(1).Select
    excelApp.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

'Delete the htm file we used in this function
 Kill TempFile




 End Function




 '################################################################
相关问题
最新问题