Question

我正在尝试创建Outlook VBA代码以将特定邮件中的附件保存到文件夹，然后将附件中的数据粘贴到另一个excel中。然后将第二个excel邮寄给某些ID。

我创建了第1条规则，将传入的自动邮件移动到特定的邮件文件夹，然后将其附件保存到桌面文件夹。保存附件后，数据将复制到第2个Excel。代码就像这样

Public Sub ExportFile(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\December\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 'workbook where the data is to be pasted
Dim wsTarget As Excel.Worksheet
Dim wbThis As Excel.Workbook 'workbook from where the data is to copied
Dim wsThis As Excel.Worksheet
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\December\Network   Critical Report\Network_Critical_Report.csv")
 Set wsThis = wbThis.Worksheets("Network_Critical_Report")
 Set wbTarget = xlApp.Workbooks.Open("C:\Users\soumyajitd\Desktop\December\Network Critical Report\Test.xlsx")
 Set wsTarget = wbTarget.Worksheets("Raw_Data")
 'select cell A1 on the target book
 'clear existing values form target book
 wsTarget.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
 wsTarget.Range("A1").PasteSpecial Paste:=xlPasteValues
 'save the target book
 wbTarget.Save
 'close the workbook
 wbTarget.Close
 wbThis.Close
 xlApp.CutCopyMode = False
 Kill ("C:\Users\soumyajitd\Desktop\December\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

第二个代码是发送一封带有“Test.xlsx”作为附件的新电子邮件。就像这样：

Sub SendNew(Item As Outlook.MailItem)

 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.ToRecipients.Add "alias@mail.com"
 objMsg.CCRecipients.Add "xx@yy.com"
 objMsg.Subject = "Subject"
 objMsg.Body = "Body"

 If FilePathtoAdd <> "" Then
 objMsg.Attachments.Add "C:\Users\soumyajitd\Desktop\December\Network Critical Report\Test.xlsx"
 End If

objMsg.Send

我在VBA编码方面经验很少。我从不同的论坛中获取了所有这些代码，并根据我的需要对其进行了修改。

现在有3个问题。

正在保存的附件不是来自最后一封邮件，而是从最后一封邮件中获取数据。
我试图通过添加接收邮件的规则来运行脚本，但它只显示了2个不同的脚本。我尝试了很多方法，但不能将它们结合起来。
第二个脚本无效，发出错误“运行时错误'-2147467259（8004005）'： “Outlook不会重新认识一个或多个名字”

Answer 1

对于您的第一个问题，请参阅THIS

第二个问题

要合并，请将一个SUB中的两个脚本加入，或者从第一个脚本中调用另一个脚本。

第3个问题

没有名为.ToRecipients和.CCRecipients的媒体资源。分别将其更改为objMsg.To = "alias@mail.com"和objMsg.CC = "xx@yy.com"。

也是你的FilePathtoAdd = ""所以你的if条件不符合。删除IF Condition或将代码更改为

FilePathtoAdd = "C:\Users\soumyajitd\Desktop\December\Network Critical Report\Test.xlsx"

With objMsg
    .To = "alias@mail.com"
    .CC = "xx@yy.com"
    .Subject = "Subject"
    .Body = "Body"
    .Attachments.Add FilePathtoAdd
End With

Outlook VBA保存邮件附件，然后将附件数据复制到另一个Excel中并通过邮件发送excel

1 个答案: