自动报告的Outlook和Excel VBA集成

因为我无法在Outlook中设置规则来运行VBA脚本，所以我尝试创建一个变通方法 .

当某个每日电子邮件带有附件时，我想下载excel附件并打开excel工作簿并在该excel中运行vba脚本来更新信息，更新图表，保存文件，并将文件作为电子邮件发送 .

我在整合方面遇到了麻烦 . 理想情况下，当电子邮件来自具有特定主题行的特定发件人时，我希望Outlook自动下载excel附件，然后运行excel vba脚本 .

我目前正在做的是在Outlook中运行一个规则，将电子邮件存档在子文件夹中，并将excel vba连接到outlook，查找电子邮件，下载文件，然后从excel运行代码，所有这些都是带有“Test”的电子邮件在主题行中显示在默认收件箱中 .

我知道这是漫长的啰嗦，但必须有一个更好的解决方案！请帮助到目前为止我的代码是：

Outlook ：

Private WithEvents Items As Outlook.Items

Private Sub Application_Startup()
  Dim olApp As Outlook.Application
  Dim objNS As Outlook.NameSpace
  Set olApp = Outlook.Application
  Set objNS = olApp.GetNamespace("MAPI")
  ' default local Inbox
  Set Items = objNS.GetDefaultFolder(olFolderInbox).Items

End Sub

Private Sub Items_ItemAdd(ByVal item As Object)

 On Error GoTo ErrorHandler
Dim Msg As Outlook.MailItem
Dim xlApp As Object
Dim oxl As Excel.Application
Dim owb As Excel.Workbook
Dim wsheet As Excel.Worksheet
Dim asd As Object
Dim ExApp As Excel.Application
Dim ExWbk As Workbook
Dim myDestFolder As Outlook.Folder


 If TypeName(item) = "MailItem" Then

Set Msg = item

    If Msg.Subject = "Test" Then

        Set ExApp = New Excel.Application
        Set ExWbk = ExApp.Workbooks.Open("excel file i want to open and run script")
        ExApp.Visible = False

        ExWbk.Application.Run "Module1.fromnew"

        Dim myNameSpace As Outlook.NameSpace
        Dim myInbox As Outlook.Folder

        Set myNameSpace = Application.GetNamespace("MAPI")
        Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox)
        Set myItems = myInbox.Items
         Set myDestFolder = myInbox.Folders("Test")

        **Msg.Move myDestFolder**
'Not working

     End If

End If
 ProgramExit:
  Exit Sub
ErrorHandler:
  MsgBox Err.Number & " - " & Err.Description
  Resume ProgramExit
  End Sub

Excel ：

Sub fromnew()


Dim myd, myy As String
Dim newfile As Workbook
Dim prod As Workbook

Call Test

'Goes into Outlook and finds the email in an Outlook subfolder and downloads 'the excel attachment.  I want to remove this and have outlook automatically 'download the attachment so I don't have to call test()

myd = Format(Date, "yyyymmdd")
myy = Format(Date, "yyyy")

Set prod = ActiveWorkbook
Set newfile = Workbooks.Open("xyz\ds\" & myy & "\blahblahblah" & myd)


newfile.Sheets(1).Range("A1:AA7000").Copy Destination:=prod.Sheets("Data").Range("A1")
prod.Sheets("Data").Range("A2") = 1
newfile.Close
prod.Activate
prod.SaveAs ("here is a file name")



Dim OutApp As Object
Dim OutMail As Object

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

On Error Resume Next
With OutMail
    .To = "email@xyz.com"
    .CC = ""
    .BCC = ""
    .Subject = "here are your things"
    .Body = "Do you like beer?"
    .Attachments.Add ("here is a file name")
    .Send   
End With
On Error GoTo 0

Set OutMail = Nothing
Set OutApp = Nothing
prod.Close
End Sub