Because I am unable to set a rule in Outlook to run a VBA script, I tried to create a workaround.
When a certain daily email comes in with an attachment, I want to download the excel attachment and open an excel workbook and run a vba script in that excel to update information, update charts, save the file, and send the file as an email.
I am having trouble with the integration. Ideally I would like to have Outlook automatically download an excel attachment when an email comes from a specific sender with a specific subject line, and then run excel vba script.
What I am currently doing is running a rule in Outlook that files the email in a sub-folder and having excel vba connect to outlook, find the email, download the file, and run code from excel, all when an email with "Test" in the subject line shows up in the default inbox.
I know this is long winded, but there has to be a better solution! Please help Here is my code so far:
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 protected]"
.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
