outlook automatisch bijlages opslaan

[enrico85]

Hallo allemaal,

Onderstaande vba code gebruik ik voor het automatisch opslaan van de bijlages (pdf formaat) in een bepaalde map in outlook.

Sub SaveAttachmentsToFolder()
' 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("Bijlages opslaan") ' 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 Sales Reports 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) = "pdf" Then
            ' This path must exist! Change folder name as necessary.
                FileName = "H:\Attachments\" & Atmt.FileName
                Atmt.SaveAsFile FileName
                i = i + 1
            End If
        Next Atmt
    Next Item
' Show summary message
    If i > 0 Then
        MsgBox "I found " & i & " attached files." _
        & vbCrLf & "I have saved them into the H:\Attachments" _
        & vbCrLf & vbCrLf & "Have a nice day!"
    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

Nu wil ik dat die niet alleen de pdf formaat opslaat maar ook de xlsx extensies.


De volgende regel had ik al aangepast:

 If Right(Atmt.FileName, 3) = "pdf" Then

naar:

 If Right(Atmt.FileName, 3) = "pdf, xlsx" Then

De regel eruit halen is geen optie want dan slaat die echt alle bijlages op. Ik wil alleen bepaalde formaten kunnen opslaan.

Iemand een idee hoe ik de code moet aanpassen?

groet
enrico

 

[gast0660]

Hoi,
Uw vraag is wat onduidelijk?
Wat werk er en wat niet?
Wil je een keuze maken?
Maar eerste antwoordje , met vier karakters denk ik ".pdf, xlxs, .xls, .doc, docx" (zie het puntje)
Greetz

 

[snb]

Het kan ook met VBA:

Sub M_snb()
  For Each it In CreateObject("Outlook.application").GetNamespace("MAPI").GetDefaultFolder(6).Items
    For Each at In it.Attachments
      if instr("_pdf_xlsx_", "_" & replace(right(at.filename,4),".","") & "_") then at.SaveAsFile "G:\OF\" & at.FileName
    Next
  Next
End Sub

 

[enrico85]

Hallo gast0660,

De vba code werkt wel maar doet nu alleen pdf bestanden opslaan. Ik wil dat die ook de xlsx bestanden gaat opslaan. Dus van alle bijlages moet die alleen de pdf bestanden en xlsx bestanden opslaan.

".pdf, xlxs, .xls, .doc, docx" dit werkt helaas niet.

groet
enrico

 

[OctaFish]

@ TS: Als je snb op de kast wilt hebben, moet je zijn oplossingen vooral blijven negeren . Wil je op je eigen voorbeeldje verder bouwen, dan kan dat zo:

    For Each Item In SubFolder.Items
        For Each Atmt In Item.Attachments
            tmp = Split(Atmt.FileName, ".")
            Select Case tmp(UBound(tmp))
                Case "pdf", "xls", "xlsx" '... En wat je er nog meer bij wilt hebben...
                    FileName = "H:\Attachments\" & Atmt.FileName
                    Atmt.SaveAsFile FileName
                    i = i + 1
            End Select
        Next Atmt

 

[snb]

@Octa

Volgens mij weet jij daarvoor nog meer methoden...

 

[enrico85]

Bedankt OctaFish!

De code van snb had ik wel geprobeerd maar sloeg alleen de bijlages van de map inbox i.p.v. submap "bijlages opslaan" op.
Dus vandaar dat ik verder ging met de code die ik al had.

In ieder geval bedankt allemaal.

groet
enrico