Script voor opslaan bijlagen

Status
Niet open voor verdere reacties.
Ik gebruik zelf Outlook 2016 en hij doet het hier prima.
 
Oooww wacht hij doet het wel. Alleen niet bij alle pdf bestanden, de bestanden DisplayFile.pdf (zo krijgen we de facturen binnen) slaat hij niet op.
Is deze bestandsnaam te kort ?
 
Heb je meer dan 1 PDF per bericht? Dan moet de code en naamgeving daarop worden aangepast.
 
Nee, 1 factuur per bericht.
Het rare is dat hij sommige wel doet maar de meeste niet....
 
Waarschijnlijk gaat het te snel. Als je een momentje hebt zal ik er de naamgeving op aanpassen ...
 
Probeer het zo eens:
Code: 
Public Sub SaveSelectionAttachments()
    Dim currentExplorer As Explorer
    Dim obj As Object
    Dim tlr As Integer

    Set currentExplorer = Application.ActiveExplorer
    Set Selection = currentExplorer.Selection

    For Each obj In Selection
       With obj
           If .Attachments.Count > 0 Then
               If Right(.Attachments(1).FileName, 3) = "pdf" Then
                    tlr = tlr + 1
                    .Attachments(1).SaveAsFile "C:\PDF Bestanden\" & Format(Now, "yyyymmddhhmmss-") & tlr & .Attachments(1).FileName
               End If
           End If
       End With
    Next

    Set currentExplorer = Nothing
    Set obj = Nothing
    Set Selection = Nothing
End Sub
 
Nee, helaas nog niet
Heel bijzonder dat hij de bijlagen DisplayFile.pdf niet wil opslaan en de andere bestanden wel.
 
Dat heeft in ieder geval niet met de naam te maken.
Wil je mij een mail sturen met zo'n bijlage?
Je kan op mijn naam klikken om me te mailen.
 
Dat kan ik helaas niet doen ivm privacy, zijn namelijk orginele facturen.
Hoop dat je dit begrijpt.
Zal morgen even op mijn werk verder kijken of ik kan traceren hoe het kan dat hij deze bestanden niet mee neemt.
Dan kan ik ook even kijken of ik een voorbeeld voor je heb.
Tot zover hartstikke bedankt !
 
Begrijp ik. Maar het werkt hier in ieder geval zonder problemen met een PDF genaamd DisplayFile.pdf
Net even getest. Ik had ook niet anders verwacht, vandaar dat ik graag even wilde bekijken wat er met die PDF aan de hand is.
Wees er tevens zeker van dat er maar 1 bijlage per mail is.
Zoals je in de code kan zien pakt hij alleen bijlage 1 uit de collectie.

Tevens zie je nu dat in vergelijking met mijn voorbeeld die andere code nogal wat overbodige zaken bevat.
 
Laatst bewerkt:
Ik heb de code nog iets aangepast. Mochten er meer PDF's bij een mail zitten dan slaat 'ie ze allemaal op.
Tevens maakt het nu niet meer uit of de extensie PDF in hoofd- of kleine letters is geschreven en is de unificatie qua naamgeving geregeld.
Code: 
Public Sub SaveSelectionAttachments()
    Dim currentExplorer As Explorer
    Dim obj As Object
    Dim i As Integer
    Dim z As Integer

    Set currentExplorer = Application.ActiveExplorer
    Set Selection = currentExplorer.Selection

    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
                    z = z + 1
                    .Attachments(i).SaveAsFile "C:\PDF Bestanden\" & 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

De PDF's worden in 1 map opgeslagen. Wat je als extra zou kunnen doen is dat er per email adres van de afzender een folder wordt gemaakt waarin de bijlagen worden opgeslagen.
 
Laatst bewerkt:
Helemaal super !
Ik ga het morgenvroeg gelijk testen op mijn werk.
Je hoort dan zo spoedig mogelijk van mij.
Nogmaals hartstikke bedankt.
 
@edmoor, da's al een mooi stukje korter dan de code in de OP.:thumb: (Nog nooit wat in Outlook geprogrammeerd maar is eigenlijk best wel handig) Naar aanleiding van jouw code lijkt dit ook te werken.

Code: 
Public Sub SaveSelectionAttachments()
  Dim it As Object, j As Long, z As Long
  For Each it In Application.ActiveExplorer.Selection
    If it.Attachments.Count > 0 Then
      For j = 1 To it.Attachments.Count
        If LCase(Right(it.Attachments(j).FileName, 3)) = "pdf" Then
          z = z + 1
          it.Attachments(j).SaveAsFile "E:\Temp\" & Format(Now, "yyyymmddhhmmss_") & Format(z, "00_") & Format(j, "00_") & it.Attachments(j).FileName
        End If
      Next j
    End If
  Next it
End Sub

Vanuit, in dit geval de variabele, 'it' is het routeren van berichten naar een specifieke map ook niet zo moeilijk. Een mens als gewoontedier......
 
Edmoor, jouw laatste code werkt perfect !!
Ben er echt super blij mee :D

Nog een laatste vraag, is het ook mogelijk om bij het opslaan een keuze te krijgen waar je de bestanden wilt opslaan ?
Dan zou het helemaal perfect zijn
 
@VenA:
Dat lijkt niet alleen te werken, dat is zelfs zo ;)
Zelf doe ik eigenlijk ook nooit wat in Outlook VBA maar ik vond de code in de OP dusdanig dramatisch dat ik er wat mee wilde doen.
Die code doet wel veel meer aan error handling en dergelijke, maar toch.

@Marten1975:
Dat kan. En wil je dat dan kunnen kiezen per bijlage of ineens voor de hele sessie?
 
Laatst bewerkt:
Kan het ook beide ?
Dus als ik 1 mailtje selecteer met een bijlage dat ik dan deze keuze krijg, maar ook als ik er bijvoorbeeld 10 selecteer...
 
Ik bedoel dus, als je 10 berichten selecteert. wil je dan een keuze per bijlage of moet de gekozen folder voor alle 10 gelden?
Voor 1 geselecteerd bericht geldt uiteraard hetzelfde.
 
Ok. Doe dan dit eens als uitbreiding op de code van VenA:
Code: 
Public Sub SaveSelectionAttachments()
  Dim it As Object, j As Long, z As Long, PDF As String
  
  PDF = BrowseForFolder("C:\")
  If PDF = "" Then Exit Sub
  For Each it In Application.ActiveExplorer.Selection
    If it.Attachments.Count > 0 Then
      For j = 1 To it.Attachments.Count
        If LCase(Right(it.Attachments(j).FileName, 3)) = "pdf" Then
          z = z + 1
          it.Attachments(j).SaveAsFile PDF & Format(Now, "yyyymmddhhmmss_") & Format(z, "00_") & Format(j, "00_") & it.Attachments(j).FileName
        End If
      Next j
    End If
  Next it
End Sub

Function BrowseForFolder(strStartingFolder As Variant) As String
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.BrowseForFolder(0, "Selecteer een folder", 0, strStartingFolder)
    If Not TypeName(objFolder) = "Nothing" Then
        Set objFolderItem = objFolder.self
        BrowseForFolder = objFolderItem.Path & "\"
    Else
        BrowseForFolder = ""
    End If

    Set objFolderItem = Nothing
    Set objFolder = Nothing
    Set objShell = Nothing
End Function
 
Laatst bewerkt:
Geweldig, dit is het !!
Edmoor en iedereen hartstikke bedankt, scheelt ons echt enorm veel handmatig werk :)
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan