automatisch bijlagen opslaan in een bestandsmap

Status
Niet open voor verdere reacties.
D

DirkB

Gebruiker
Lid geworden
24 jun 2014
Berichten
96
Hoi,

Ik heb al heel veel vragen beantwoordt gekregen op het Excel forum maar nu heb ik een vraag over Outlook (2010)
Ik wil graag (PDF) bijlagen die ik per mail van een bepaalde afzender ontvang, opslaan in een map op onze server.


Ik heb het een en ander geprobeerd met regels maar daar vindt ik niet zoveel over bijlagen


Kan iemand me op weg helpen?
 
Je kunt dat wel met een VBA functie doen, die op gezette tijden wordt gestart. Ik weet niet of je het voor elke mail wilt doen, al kun je die procedure nog wel zo instellen dat hij het voor bepaalde email adressen doet.
 
Dat heb ik een tijdje geleden voor iemand hier gemaakt.
Plak dit in de ThisOutlookSession sectie.
Selecteer de mail(s) met de PDF, ga dan weer naar de zojuist gemaakte Sub en druk op F5 om deze te activeren:

Code: 
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
           End If
       End With
    Next

    Set currentExplorer = Nothing
    Set obj = Nothing
    Set Selection = Nothing
End Sub

Je kan het ook zo maken dat het al gebeurt op het moment dat een mail met een PDF bijlage binnen komt.
En, wat Octafish al noemde, evt. alleen voor bepaalde afzenders.
 
Laatst bewerkt:
edmoor

ik heb je code gebruikt op de manier zoals je aangeeft
hij slaat de mail op en niet de alleen de pdf
en klopt het dan ik dan voor elke opsla actie naar vba moet?

ik zou eigenlijk een stukje code willen gebruiken dat de pdf opslaat op de server op basis van een regel

zo van als ik een mail ontvang van …
dan
vba code voor opslaan pdf

maar ik weet niet of dat mogelijk is

anders moet ik de mail openen en de pdf naar de juiste map slepen , kan ook maar is iets meer werk
 
Ik plaatste wat ik heb, als voorbeeld.
Hij slaat de mail niet op, alleen de PDF in een map met het email adres van de afzender.
En, wat ik al zei, het kan zo worden aangepast dat het automatisch gebeurd als een mail met PDF bijlage binnen komt en ook kan je het zo aanpassen dat het alleen voor 1 of bepaalde adressen gebeurd.
 
Hoi Edmoor, dank voor je reactie
Ik heb getracht je code te 'lezen'
Ben niet heel erg thuis in vba en zie niet helemaal waar en hoe ik het moet aanpassen

Bijv. Hoe kan ik bereiken dat de code het bij elke binnenkomende mail doet?
en hoe ik bereiken dat het alleen werkt bij 1 afzender? of nog mooier met bepaalde tekst in de onderwerp regel


Alvast bedankt

Dirk
 
Kheb het toch nog maar even gedaan. Dit is de complete code. Wijzig de rode tekst in wat je wilt: (Alleen kleine letters gebruiken)
Code: 
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

Na het plaatsen van deze code wel even Outlook een keer herstarten.
 
Laatst bewerkt:
Edmoor, bedankt voor je moeite

ik heb de code geplaatst bij 'this outlook session'
helaas gebeurt er niets

(ik krijg ook geen meldingen)

ik heb het opgeslagen, kleine letters gebruikt en outlook opnieuw gestart

wat doe ik fout?
 
Dat kan ik zo niet zeggen.
Hier werkt het perfect.
Laat eens een schermafdruk van het VBA scherm zien.
Met welke versie van Outlook werk je?
 
Dat ziet er goed uit.
Het doet dus op zichzelf niks maar treedt in werking als er een mail binnenkomt in de default inbox.
Als dat het onderwerp overeenkomt gaat hij kijken of er een PDF bijlage is en zoja, slaat deze dan op.
 
Edmoor, het werkt perfect,
thanks

typefoutje in het onderwerp gemaakt:(
had beter op moeten letten bij de typecursus vroeger op school
 
Ok dan :thumb:
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan