Problem activating code at proper time

[babycody]

Hello everyone! I found this code, and placed it in a module. I commented out the messages, and changed it to suit. I don't have a lot of experience coding in Outlook. I do have some experience with VBA in Excel. I have six subs in a module. Each does pretty much the same thing. I used this sub in ThisOutlookSession module to call the subs in the regular module. The problem is that the code doesn't seem to activate until I receive the next email message. I am using rules to move messages to subfolders. When a message gets put into one of these folders its attachment is renamed and saved in a folder within a folder on my desktop. The code seems to work properly, but it isn't being triggered at the correct time. Can you advise me as to what I am doing incorrectly?

Private Sub Application_NewMail()
Call SaveAttachmentsToShipTotal
Call SaveAttachmentsToUsage
Call SaveAttachmentsToOrders
Call SaveAttachmentsToFertilizerAdjustments
Call SaveAttachmentsToGranularAdjustments
Call SaveAttachmentsToLiquidAdjustments
End Sub
Here is one example of a sub that is being called:

Sub SaveAttachmentsToFertilizerAdjustments()
' This Outlook macro checks a named subfolder in the Outlook Inbox
' (here the "Sales Reports" folder) for messages with attached
' files of a specific type (here file with an "xls" extension)
' and saves them to disk. Saved files are timestamped. The user
' can choose to view the saved files in Windows Explorer.
' NOTE: make sure the specified subfolder and save folder exist
' before running the macro.
On Error GoTo SaveAttachmentsToFolder_err
' Declare variables
Dim ns As NameSpace
Dim Inbox As MAPIFolder
Dim SubFolder As MAPIFolder
Dim Item As Object
Dim Atmt As Attachment
Dim FileName As String
Dim i As Integer
Dim varResponse As VbMsgBoxResult
Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
Set SubFolder = Inbox.Folders("Fertilizer Adjustments") ' Enter correct subfolder name.
i = 0
' Check subfolder for messages and exit of none found
'If SubFolder.Items.Count = 0 Then
' MsgBox "There are no messages in the ship total folder.", vbInformation, _
' "Nothing Found"
' Exit Sub
'End If
' Check each message for attachments
For Each Item In SubFolder.Items
For Each Atmt In Item.Attachments
' Check filename of each attachment and save if it has "xls" extension
If Right(Atmt.FileName, 3) = "xls" Then
' This path must exist! Change folder name as necessary.
FileName = "C:\Documents and Settings\wharper\Desktop\BS by Wayne\Fertilizer Adjustment\" & _
"Fertilizer Adjustments.xls"
Atmt.SaveAsFile FileName
i = i + 1
End If
Next Atmt
Next Item
' Show summary message
'If i > 0 Then
' varResponse = MsgBox("I found " & i & " attached files." _
' & vbCrLf & "I have saved them into the C:\Documents and Settings\wharper\Desktop\Ship Total." _
' & vbCrLf & vbCrLf & "Would you like to view the files now?" _
' , vbQuestion + vbYesNo, "Finished!")
' Open Windows Explorer to display saved files if user chooses
'If varResponse = vbYes Then
'Shell "Explorer.exe /e,C:\Documents and Settings\wharper\Desktop\Ship Total", vbNormalFocus
'End If
'Else
' MsgBox "I didn't find any attached files in your mail.", vbInformation, "Finished!"
'End If
' Clear memory
SaveAttachmentsToFolder_exit:
Set Atmt = Nothing
Set Item = Nothing
Set ns = Nothing
Exit Sub
' Handle Errors
SaveAttachmentsToFolder_err:
MsgBox "An unexpected error has occurred." _
& vbCrLf & "Please note and report the following information." _
& vbCrLf & "Macro Name: GetAttachments" _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume SaveAttachmentsToFolder_exit
End Sub
Thank you for taking a look.

[mvidas]

Hi BabyCody,

What do you mean that it isn't firing at the right time, that it waits until it gets another message?
I've noticed you're saving the file to the same name every time, which will overwrite the previous time. Is this intentional?

What I think might suit you a little better is to use the _ItemAdd event on each folder to check your folders for new messages (so it won't check all 6 when an email is received into just your regular inbox or another unimportant folder).
I'd be happy to help convert all your subs over to this style; outlook vba has become my recent hobby and I enjoy all the practice I can get.

Assuming all your code is generally the same, with the exception of the folder names and save folder for them, paste the following into your ThisOutlookSession object. It creates the Items objects for each of your folders, and has the _ItemAdd event for each. One function is used to save the attachments, and I pass the item and save path to it from each. After it is processed, it is marked as read. When the function is first initialized (either by the application starting up or by running the "StartChecking" sub), it looks in each folder for unread messages and checks them as well:Option Explicit
Dim WithEvents olFertilizerAdjustments As Outlook.Items
Dim WithEvents olShipTotal As Outlook.Items
Dim WithEvents olUsage As Outlook.Items
Dim WithEvents olOrders As Outlook.Items
Dim WithEvents olGranularAdjustments As Outlook.Items
Dim WithEvents olLiquidAdjustments As Outlook.Items
Private Sub Application_Startup()
StartChecking
End Sub
Private Sub Application_Quit()
Set olFertilizerAdjustments = Nothing
Set olShipTotal = Nothing
Set olUsage = Nothing
Set olOrders = Nothing
Set olGranularAdjustments = Nothing
Set olLiquidAdjustments = Nothing
End Sub
Sub StartChecking()
Dim ns As NameSpace, Inbox As MAPIFolder, Item As Object
Set ns = Application.GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
With Inbox
Set olShipTotal = .Folders("Ship Total").Items
Set olUsage = .Folders("Usage").Items
Set olOrders = .Folders("Orders").Items
Set olFertilizerAdjustments = .Folders("Fertilizer Adjustments").Items
Set olGranularAdjustments = .Folders("Granular Adjustments").Items
Set olLiquidAdjustments = .Folders("Liquid Adjustments").Items
End With
Set ns = Nothing
Set Inbox = Nothing
For Each Item In olShipTotal
If Item.UnRead Then Call olShipTotal_ItemAdd(Item)
Next
For Each Item In olUsage
If Item.UnRead Then Call olUsage_ItemAdd(Item)
Next
For Each Item In olOrders
If Item.UnRead Then Call olOrders_ItemAdd(Item)
Next
For Each Item In olFertilizerAdjustments
If Item.UnRead Then Call olFertilizerAdjustments_ItemAdd(Item)
Next
For Each Item In olGranularAdjustments
If Item.UnRead Then Call olGranularAdjustments_ItemAdd(Item)
Next
For Each Item In olLiquidAdjustments
If Item.UnRead Then Call olLiquidAdjustments_ItemAdd(Item)
Next
End Sub
Private Sub olShipTotal_ItemAdd(ByVal Item As Object)
If TypeName(Item) <> "MailItem" Then Exit Sub
If Item.Attachments.Count > 0 Then
Call SaveAttachments(Item, CheckMakePath(DesktopAddress & _
"BS by Wayne\Ship Total\"))
End If
Item.UnRead = False
End Sub
Private Sub olUsage_ItemAdd(ByVal Item As Object)
If TypeName(Item) <> "MailItem" Then Exit Sub
If Item.Attachments.Count > 0 Then
Call SaveAttachments(Item, CheckMakePath(DesktopAddress & _
"BS by Wayne\Usage\"))
End If
Item.UnRead = False
End Sub
Private Sub olOrders_ItemAdd(ByVal Item As Object)
If TypeName(Item) <> "MailItem" Then Exit Sub
If Item.Attachments.Count > 0 Then
Call SaveAttachments(Item, CheckMakePath(DesktopAddress & _
"BS by Wayne\Orders\"))
End If
Item.UnRead = False
End Sub
Private Sub olLiquidAdjustments_ItemAdd(ByVal Item As Object)
If TypeName(Item) <> "MailItem" Then Exit Sub
If Item.Attachments.Count > 0 Then
Call SaveAttachments(Item, CheckMakePath(DesktopAddress & _
"BS by Wayne\Liquid Adjustments\"))
End If
Item.UnRead = False
End Sub
Private Sub olGranularAdjustments_ItemAdd(ByVal Item As Object)
If TypeName(Item) <> "MailItem" Then Exit Sub
If Item.Attachments.Count > 0 Then
Call SaveAttachments(Item, CheckMakePath(DesktopAddress & _
"BS by Wayne\Granular Adjustments\"))
End If
Item.UnRead = False
End Sub
Private Sub olFertilizerAdjustments_ItemAdd(ByVal Item As Object)
If TypeName(Item) <> "MailItem" Then Exit Sub
If Item.Attachments.Count > 0 Then
Call SaveAttachments(Item, CheckMakePath(DesktopAddress & _
"BS by Wayne\Fertilizer Adjustments\"))
End If
Item.UnRead = False
End Sub
Private Function SaveAttachments(ByVal Item As Object, ByVal SavePath As String) _
As Boolean
Dim Atmt As Attachment
On Error GoTo SaveAttachmentsToFolder_err
For Each Atmt In Item.Attachments
' Check filename of each attachment and save if it has "xls" extension
If LCase(Right(Atmt.FileName, 3)) = "xls" Then
Atmt.SaveAsFile SavePath & Atmt.FileName
End If
Next 'Atmt
' Clear memory
SaveAttachmentsToFolder_exit:
Set Atmt = Nothing
Exit Function
' Handle Errors
SaveAttachmentsToFolder_err:
MsgBox "An unexpected error has occurred." _
& vbCrLf & "Please note and report the following information." _
& vbCrLf & "Folder Name: " & Item.Parent.Name _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume SaveAttachmentsToFolder_exit
End Function
Private Function DesktopAddress() As String
Dim WShell As Object
Set WShell = CreateObject("wscript.shell")
DesktopAddress = WShell.SpecialFolders("Desktop") & "\"
Set WShell = Nothing
End Function
Private Function CheckMakePath(ByVal vPath As String) As String
Dim PathSep As Long, oPS As Long
If Right(vPath, 1) <> "\" Then vPath = vPath & "\"
PathSep = InStr(3, vPath, "\") 'position of drive separator in path
If PathSep = 0 Then Exit Function 'invalid path
Do
oPS = PathSep
PathSep = InStr(oPS + 1, vPath, "\") 'position of directory
If PathSep = 0 Then Exit Do
If Len(Dir(Left(vPath, PathSep), vbDirectory)) = 0 Then Exit Do 'check path
Loop
Do Until PathSep = 0
MkDir Left(vPath, PathSep)
oPS = PathSep
PathSep = InStr(oPS + 1, vPath, "\")
Loop
CheckMakePath = vPath
End Function
Doing it this way should save a lot of code, and you can see how the Items events work too.
Please let me know if you have any questions!
Matt

[babycody]

Thanks Matt! You really put in a lot of effort on this. I wanted to ask you a question and answer two of yours. You wanted to know if it was my intention to overwrite the old file with the new. That is what I want to do. I receive a new .xls file everyday that people add the date to the name. I want to give the file the same name so that I don't have to change my formulas to reference new workbook names everyday. This is the most important part for me, and the reason for all of the code.

What do you mean that it isn't firing at the right time, that it waits until it gets another message?
When an email arrived, that met the criteria I setup in the rules wizard, it was moved to one of the subfolders. However the code didn't rename and move the attachment until the next email arrived. What I believe happened was the code fired as soon as the new email arrived. There wasn't any time for the rules wizard to move the email into the subfolder before this happened. So when the code ran the email hadn't been moved yet. When I received the next email it activated the code again, and this time a new message was found in the subfolder. That would be my guess.

I haven't had a chance to try your code yet. I wanted to make sure that we were on the same page about the file naming first. Does your code do what I am describing?

[mvidas]

Interesting about the timing thing, I use _newmail to check a couple subfolders myself from rules and it works without issue.. Maybe try adding "DoEvents" at the top of what you have to see if that makes it process the rules first.

It will do what you want, if you make one slight change. In the 'SaveAttachments' function, I changed your code to use the original attachment's name. Change this block: If LCase(Right(Atmt.FileName, 3)) = "xls" Then
Atmt.SaveAsFile SavePath & Atmt.FileName
End If
To: If LCase(Right(Atmt.FileName, 3)) = "xls" Then
Atmt.SaveAsFile SavePath & Item.Parent.Name & ".xls"
End If

That will save it with a filename based on the containing outlook folder's name. So the emails in your "Fertilizer Adjustments" folder will be called "Fertilizer Adjustments.xls". If you'd prefer a different name then the parent folder's name, the function can be changed to specify the file name as well.

Also, though I didnt specify it, if your desktop subfolders don't already exist, the code creates them (in the CheckMakePath function). This way if another user uses this code, the folders will be created for them.

[babycody]

Thank you Matt. With the "DoEvents" do I just place that right after the DIMs all be itself? The help files on this aren't very helpful. When I get caught up on my workload I am looking forward to testing out your code. I really appreciate the help you've given me.

[mvidas]

In sticking with your original code, you could put it in the _newmail event, likePrivate Sub Application_NewMail()
DoEvents
Call SaveAttachmentsToShipTotal
Call SaveAttachmentsToUsage
Call SaveAttachmentsToOrders
Call SaveAttachmentsToFertilizerAdjustments
Call SaveAttachmentsToGranularAdjustments
Call SaveAttachmentsToLiquidAdjustments
End Sub