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
If TypeName(item) = "MailItem" Then
If LCase(item.Subject) = "[COLOR="#FF0000"]dit is het onderwerp[/COLOR]" Then
SaveSelectionAttachments
End If
End If
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub
Public Sub SaveSelectionAttachments()
Dim currentExplorer As Explorer
Dim PDFroot As String
Dim Fldr As String
Dim obj As Object
Dim i As Integer
Dim z As Integer
Set currentExplorer = Application.ActiveExplorer
Set Selection = currentExplorer.Selection
PDFroot = "C:\PDF Bestanden\"
If Dir(PDFroot, vbDirectory) = "" Then
MsgBox "De PDF root folder bestaat niet of niet niet toegankelijk" & vbCrLf & PDFroot, vbCritical
Exit Sub
End If
For Each obj In Selection
With obj
If .Attachments.Count > 0 Then
For i = 1 To .Attachments.Count
If LCase(Right(.Attachments(i).FileName, 3)) = "pdf" Then
Fldr = PDFroot & .SenderEmailAddress
If Dir(Fldr, vbDirectory) = "" Then
On Error Resume Next
MkDir Fldr
If Err.Number = 76 Then
Fldr = PDFroot & "\Diversen"
If Dir(Fldr, vbDirectory) = "" Then
MkDir Fldr
End If
End If
On Error GoTo 0
End If
z = z + 1
.Attachments(i).SaveAsFile Fldr & "\" & _
Format(Now, "yyyymmddhhmmss_") & _
Format(z, "0##_") & _
Format(i, "0##_") & _
.Attachments(i).FileName
End If
Next i
MsgBox "PDF opgeslagen", vbInformation
End If
End With
Next
Set currentExplorer = Nothing
Set obj = Nothing
Set Selection = Nothing
End Sub