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

Outlook VBA to save attachment from a mail,and then copy the attachment data in another excel and send the send excel via mail

提问by Soumyajit

I am trying to create a Outlook VBA code to save attachments from a particular mail to a folder,then copy paste the data from the attachment in another excel.And then mail the 2nd excel to some ids.

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

I have created a rule 1st to move the incoming auto mail to a particular mail folder,Then save its attachment to the desktop folder.After saving the attachment the data gets copied to the 2nd excel. The code is like this

我创建了一个规则 1st 将传入的自动邮件移动到特定的邮件文件夹，然后将其附件保存到桌面文件夹。保存附件后，数据被复制到第二个 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

The second code is to send a new email with "Test.xlsx" as attachment.It is like this :

第二个代码是发送一封带有“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 "[email protected]"
 objMsg.CCRecipients.Add "[email protected]"
 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

I have very little experience in VBA coding.I have taken all these codes from different forums and have modified them to suit my need.

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

Now there are 3 problems.

现在有3个问题。

1. The attachment which is getting saved is not from the last mail,it is taking the data from the 2nd last mail.
2. I am trying to run the script by adding rule for receiving mail,but it is showing only the 2 different scripts. I tried many ways but couldnot combine both of them.
3. The 2nd script is not working,giving an error "Runtime error '-2147467259(8004005)': "Outlook doesnot recongnize 1 or more names"

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

回答by Siddharth Rout

For your 1st Problem, see THIS

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

For your 2nd Problem

对于你的第二个问题

To combine, either join both the scripts in one SUBor call the other from the first.

要合并，要么将两个脚本合并成一个，要么SUB从第一个开始调用另一个。

For your 3rd Problem

对于你的第三个问题

There is no property called .ToRecipientsand .CCRecipients. Change it to objMsg.To = "[email protected]"and objMsg.CC = "[email protected]"respectively.

没有名为.ToRecipientsand 的属性.CCRecipients。将其分别更改为objMsg.To = "[email protected]"和objMsg.CC = "[email protected]"。

Also your FilePathtoAdd = ""so your if condition is not met. Either delete that IF Condition or change your code to this

也是你的FilePathtoAdd = ""所以你的 if 条件不满足。删除该 IF 条件或将您的代码更改为此

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

With objMsg
    .To = "[email protected]"
    .CC = "[email protected]"
    .Subject = "Subject"
    .Body = "Body"
    .Attachments.Add FilePathtoAdd
End With