Pulling Specified Attachments: VBA

[thejester]

Currently, I have the following code and rule set up working, which automatically pulls attachments from incoming emails and saves them to a shared drive in Outlook 2010. This also is pulling in signatures, etc, of which I do not need. I solely need ".pdf" files to be extracted from emails and saved to the shared folder. I know I am missing a simple line of code in order to accomplish this, but after several attempts, I think I may keep finding the right "IF" statement, but I can't seem to figure out what it is or where to put it.

Public Sub SaveAttachmentsToDisk(MItem As Outlook.MailItem)
Dim ns As NameSpace
Dim Inbox As MAPIFolder
Dim Item As Object
Dim Atmt As Attachment
Dim FileName As String
Dim i As Integer

Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
i = 0

For Each Item In Inbox.Items
For Each Atmt In Item.Attachments
FileName = "\\Invoices for Processing" & _
Format(Item.CreationTime, "yyyymmdd_hhmmss_") & Atmt.FileName
Atmt.SaveAsFile FileName
i = i + 1
Next Atmt
Next Item


End Sub

Any help would be greatly appreciated. Thanks.

[thejester]

UPDATE:
I was able to get the specific file time to be the only file pulled, but now I need to know how to get a different email inbox to be the one that it pulls from, IE: it is currently pulling everything from thejesterAT..... and I need it to pull from APInvoicesAT.....

Forum wouldn't let me post updated VBA ???

[thejester]

Figured out it doesn't like "AT" signs. :D

Public Sub SaveAttachmentsToDisk(MItem As Outlook.MailItem)
Dim ns As NameSpace
Dim Inbox As MAPIFolder
Dim Item As Object
Dim Atmt As Attachment
Dim FileName As String
Dim i As Integer
Dim myExt As String

Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
i = 0

For Each Item In Inbox.Items
For Each Atmt In Item.Attachments
myExt = Mid(Atmt.FileName, InStrRev(Atmt.FileName, Chr(46)))
Select Case myExt
Case ".pdf"
FileName = "\\AP Invoices for Processing" & _
Format(Item.CreationTime, "yyyymmdd_hhmmss_") & Atmt.FileName
Atmt.SaveAsFile FileName
i = i + 1
Case Else
End Select
Next Atmt
Next Item


End Sub

[gmayor]

If you are running this code on messages as they arrive using a rule, why are you then looking at all the items in inbox? It is the item that arrives that is of interest. So assuming that your file path is correct the following is all you require.


Public Sub SaveAttachmentsToDisk(Item As Outlook.MailItem)
Dim Atmt As Attachment
Dim FileName As String
Dim myExt As String
For Each Atmt In Item.Attachments
myExt = Mid(Atmt.FileName, InStrRev(Atmt.FileName, Chr(46)))
Select Case myExt
Case ".pdf"
FileName = "\\AP Invoices for Processing" & _
Format(Item.CreationTime, "yyyymmdd_hhmmss_") & Atmt.FileName
Atmt.SaveAsFile FileName
Case Else
End Select
Next Atmt
End Sub

[thejester]

Because I'm a noob, :doh: this worked perfectly, thank you very much. :cool:

[thejester]

One issue that I see remains though, this client is using Outlook 2010. If they go home at night, IE: close out of outlook, when it is reopened, the new emails are there, but it isn't detaching the .pdf's into the shared drive. This is only happening if outlook is running. Is there a correction or just the way it is?

[thejester]

testing on and off with my Outlook 2016, and it works either on or once turned on, I'm wondering if her 2010 may be the issue. Thoughts?

[thejester]

OR, can you do the exact same code you have above, but for Outlook 2010? Not sure if these clients have the licenses to upgrade this Outlook 2010 to 2016.
I tested the script on my Outlook 2016 and it worked flawlessly, with or without Outlook open.
I apologize for the multiple posts, my thoughts have been on other issues today. Thanks in advance.

[gmayor]

Outlook 2010 and 2016 are operationally similar with regard to processing VBA code, however as the code is run in Outlook, Outlook needs to be running for the code to work in either version. There may be security implications ion which case see
http://www.gmayor.com/create_and_employ_a_digital_cert.htm (http://www.gmayor.com/create_and_employ_a_digital_cert.htm)

[thejester]

The code is working in both, though the 2010 seems to work for a few and then stop, so the certificate option may be the way to go, however, the 2016 version on my PC of course doesn't run the script when it is not open, but once Outlook is opened, the script runs and all the new emails do as they are told. I created the certificate on her 2010 PC, but I couldn't see where to go view the certificate from the steps you gave to test :/ and then got lost.
The client is going to be getting a new PC, so this may be a moot point, as everything on her current PC will be getting updated/upgraded.
Thanks for the help. I'm sure I will have more VBA Outlook questions at a later date.

[gmayor]

If there's a security issue the macro won't run at all next time Outlook is opened, so the fact that it does suggests this is not the issue.
Sometimes For Each ... Next loops don't behave well so try


Public Sub SaveAttachmentsToDisk(Item As Outlook.MailItem)
Dim Atmt As Attachment
Dim FileName As String
Dim myExt As String
Dim lngIndex As Long
For lngIndex = 1 To Item.Attachments.Count
Set Atmt = Item.Attachments(lngIndex)
myExt = Mid(Atmt.FileName, InStrRev(Atmt.FileName, Chr(46)))
Select Case myExt
Case ".pdf"
FileName = "\\AP Invoices for Processing" & _
Format(Item.CreationTime, "yyyymmdd_hhmmss_") & Atmt.FileName
Atmt.SaveAsFile FileName
Case Else
End Select
Next lngIndex
lbl_Exit:
Set Atmt = Nothing
Exit Sub
End Sub

[thejester]

Ok, well, a bit of a step in the wrong direction. I have a new PC for the client, I have installed the 2016 office, with Outlook 2016, and now the VB code doesn't work at all. I believe it is running, but it doesn't pull the attachment off the email and save it to the location. :banghead:

[gmayor]

Almost certainly the problem is with your path and filename


FileName = "\\AP Invoices for Processing" & _
Format(Item.CreationTime, "yyyymmdd_hhmmss_") & Atmt.FileName
Use the correct full path here such as

FileName = "C:\Path\AP Invoices for Processing\" & _
Format(Item.CreationTime, "yyyymmdd_hhmmss_") & Atmt.FileName

[thejester]

I thought the same thing, but have since deleted the email account and the rule to start from scratch. Reinstalled the email account and recreated the rule as the last script written above. NOW, the rule ONLY runs with I use the "Run Rule Now" button.
???

USING

Public Sub SaveAttachmentsToDisk(Item As Outlook.MailItem)
Dim Atmt As Attachment
Dim FileName As String
Dim myExt As String
For Each Atmt In Item.Attachments
myExt = Mid(Atmt.FileName, InStrRev(Atmt.FileName, Chr(46)))
Select Case myExt
Case ".pdf"
FileName = "...\AP Invoices for Processing" & _
Format(Item.CreationTime, "yyyymmdd_hhmmss_") & Atmt.FileName
Atmt.SaveAsFile FileName
Case Else
End Select
Next Atmt
End Sub

[thejester]

I've double checked that I don't have an errant "." or space any place, but without using the actual server, the patch is a mapped drive to:
\\1.1.1.1\Attachments\AP Invoices for Processing\

it was working great on my pc, but I can not get it to initiate on hers. She now has Office 2016 (Outlook), I've enabled the "unsafe" "run a script" tab in the registry. I know there is a password to get to the mapped location, would that suddenly make a difference? It didn't before. Yes, I'm making sure the drive is mapped and is connected when trying to run the script. No ideas what would keep it from running at this point or why it was running on my desktop, then stopped.

[thejester]

[SOLVED]
Thank you sweet (insert appropriate religious figure to your belief system here)!!!!
Finally figured this out. In the Macro Security tab, which I hadn't seen due to the developer tab wasn't activated, "Notifications for digitally signed macros, all other macros disabled" was CHECKED. I simply changed that to "Enable all macros....." and it went, like a dream.
Thank you for all your patience and advice. I'm exhausted :D
[SOLVED]

[thejester]

The above was solved....fast forward a year or so to now, and I'm trying to move this over to a new user account. I'm getting this:
24833

What am I doing wrong?

[gmayor]

There should be a line break between

Next lngIndex
lbl_Exit:as shown in the original code.

[gazmoz17]

If there's a security issue the macro won't run at all next time Outlook is opened, so the fact that it does suggests this is not the issue.
Sometimes For Each ... Next loops don't behave well so try


Public Sub SaveAttachmentsToDisk(Item As Outlook.MailItem)
Dim Atmt As Attachment
Dim FileName As String
Dim myExt As String
Dim lngIndex As Long
For lngIndex = 1 To Item.Attachments.Count
Set Atmt = Item.Attachments(lngIndex)
myExt = Mid(Atmt.FileName, InStrRev(Atmt.FileName, Chr(46)))
Select Case myExt
Case ".pdf"
FileName = "\\AP Invoices for Processing" & _
Format(Item.CreationTime, "yyyymmdd_hhmmss_") & Atmt.FileName
Atmt.SaveAsFile FileName
Case Else
End Select
Next lngIndex
lbl_Exit:
Set Atmt = Nothing
Exit Sub
End Sub


Hi I seem to get an error for the section I have highlighted red?

Thanks