Outlook Macro to move PDF attachments to hard drive - vba

Question

My goal is: on incoming email, move any PDF attachments to a hard drive folder with the date appended to the end of it.
I had a macro running with a rule, but the rule constantly errors and turns off, So I am going to put it in This Outlook Session.
I modified this macro that I found to do what I need, however it is giving me the compile error: Next without For.
Thank you for your assistance on this.
Option Explicit
Private WithEvents olInboxItems As Items
Private Sub Application_Startup()
Dim objNS As NameSpace
Set objNS = Application.Session
' instantiate objects declared WithEvents
Set olInboxItems = objNS.GetDefaultFolder(olFolderInbox).Items
Set objNS = Nothing
End Sub
Private Sub olInboxItems_ItemAdd(ByVal Item As Object)
On Error Resume Next
If Item.Attachments.Count > 0 Then
Dim objAttachments As Outlook.Attachments
Dim lngCount As Long
Dim strFile As String
Dim sFileType As String
Dim i As Long
Dim dtDate As Date
Dim sName As String
Dim objMsg As Outlook.MailItem
Dim lcount As Integer
Dim pre As String
Dim ext As String
Dim strFolderpath As String
Set objAttachments = Item.Attachments
lngCount = objAttachments.Count
For i = lngCount To 1 Step -1
If lngCount > 0 Then
dtDate = objMsg.SentOn
sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, vbUseSystem)
' Get the file name.
strFile = sName & objAttachments.Item(i).FileName
If LCase(Right(strFile, 4)) = ".pdf" Then
lcount = InStrRev(strFile, ".") - 1
pre = Left(strFile, lcount)
ext = Right(strFile, Len(strFile) - lcount)
' Combine with the path to make the final path
strFile = strFolderpath & pre & "_" & sName & ext
' Get the path to your My Documents folder
strFolderpath = CreateObject("WScript.Shell").ExpandEnvironmentStrings("%USERPROFILE%")
strFolderpath = strFolderpath & "\1 Inbox\"
' Combine with the path to the folder.
strFile = strFolderpath & strFile
' Save the attachment as a file.
objAttachments.Item(i).SaveAsFile strFile
Next i
End If
End If
End Sub

Answer 1

You don't need rule, try adding this to OutlookSession then restart your Outlook
Private WithEvents Items As Outlook.Items
Private Sub Application_Startup()
Dim olNs As Outlook.NameSpace
Dim Inbox As Outlook.MAPIFolder
Set olNs = Application.GetNamespace("MAPI")
Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
Set Items = Inbox.Items
End Sub
Private Sub Items_ItemAdd(ByVal Item As Object)
If TypeOf Item Is Outlook.MailItem Then
Save_PDF Item
End If
End Sub
Private Sub Save_PDF(ByVal Item As Object)
Dim Atmts As Outlook.Attachments
Dim intCount As Long
Dim sFileName As String
Dim i As Long
Dim sDate As String
Dim Frmt_Date As String
Dim FolderPath As String
If Item.Attachments.Count > 0 Then
Set Atmts = Item.Attachments
intCount = Atmts.Count
For i = intCount To 1 Step -1
If intCount > 0 Then
sDate = Item.SentOn
Frmt_Date = Format(sDate, "yyyymmdd", vbUseSystemDayOfWeek, vbUseSystem)
' Get the file name.
sFileName = Atmts.Item(i).FileName
If LCase(Right(sFileName, 4)) = ".pdf" Then
' Get the path to your My Documents folder
FolderPath = Environ("USERPROFILE") & "\Documents\1 Inbox\"
' Combine with the FolderPath and FileName_DateSentOn
sFileName = FolderPath & Frmt_Date & "_" & sFileName
' Save the attachment as a file.
Atmts.Item(i).SaveAsFile sFileName
End If
End If
Next i
End If
Set Items = Nothing
Set Atmts = Nothing
End Sub