Marco aanpassen, van save as itemname TO sendername

[koenschutte]

Hallo,

Ik heb heel wat forums gezocht om mij te helpen met dit probleem.. jullie zijn mijn laatste redmiddel!
Bij de inventarisaties van verschillende dingen krijg ik mails binnen met een PDF bijlage.

Nu is het zo dat hij de naam van de PDF overneemt en indien die al bestaat er een getal achter zet.
Ik wil alleen dat het bestandsnaam gelijk is aan OF het e-mailadres van de verzender (zou ideaal zijn) en anders de naam van de verzender.

Hoe kan ik dit realiseren?

Ik heb al verschillende aanpassingen geprobeerd, echter snap ik er zelf niks van.

Option Explicit


Sub GetAttachments()
On Error Resume Next
'create the folder if it doesnt exists:
    Dim fso, ttxtfile, txtfile, WheretosaveFolder
    Dim objFolders As Object
    Set objFolders = CreateObject("WScript.Shell").SpecialFolders
 
    'MsgBox objFolders("mydocuments")
    ttxtfile = objFolders("mydocuments")
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set txtfile = fso.CreateFolder(ttxtfile & "email attachements")
    ' ------------------------------------------------------
        ' Set fso = Nothing
    ' ------------------------------------------------------
    WheretosaveFolder = ttxtfile & "\email attachments"
    
On Error GoTo GetAttachments_err
' Declare variables
    Dim ns As NameSpace
    Dim Inbox As MAPIFolder
    Dim Item As Object
    Dim Atmt As Attachment
    Dim FileName As String
    Dim I As Integer
    Set ns = GetNamespace("MAPI")
    'Set Inbox = ns.GetDefaultFolder(olFolderInbox)
    ' added the option to select whic folder to export
    Set Inbox = ns.PickFolder
    
    'to handle if the use cancalled folder selection
    If Inbox Is Nothing Then
                MsgBox "Selecteer eerst eens een mapje.", vbCritical, _
               "Export - Not Found"
        Exit Sub
    End If

    ''''
    

    I = 0
' Check Inbox for messages and exit of none found
    If Inbox.Items.Count = 0 Then
        MsgBox "Moet er wel wat instaan.", vbInformation, _
               "Export - Not Found"
        Exit Sub
    End If
' Check each message for attachments
    For Each Item In Inbox.Items
' Save any attachments found
        For Each Atmt In Item.Attachments
        ' This path must exist! Change folder name as necessary.
        ' ------------------------------------------------------
            FileName = WheretosaveFolder & "\" & fso.GetBaseName(Atmt.FileName) & I & "." & fso.GetExtensionName(Atmt.FileName)
        ' ------------------------------------------------------
            Atmt.SaveAsFile FileName
            I = I + 1
         Next Atmt
    Next Item
' Show summary message
    If I > 0 Then
        MsgBox "There were " & I & " attached files." _
        & vbCrLf & "These have been saved to the Email Attachments folder in My Documents." _
        & vbCrLf & vbCrLf & "Gelukt!", vbInformation, "Export Complete"
    Else
        MsgBox "There were no attachments found in any mails.", vbInformation, "Export - Not Found"
    End If
    ' ------------------------------------------------------
        Set fso = Nothing
    ' ------------------------------------------------------
' Clear memory
GetAttachments_exit:
    Set Atmt = Nothing
    Set Item = Nothing
    Set ns = Nothing
    Exit Sub
' Handle errors
GetAttachments_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 GetAttachments_exit
End Sub

 

[wampier]

De "magie" zit in deze regel:

FileName = WheretosaveFolder & "\" & fso.GetBaseName(Atmt.FileName) & I & "." & fso.GetExtensionName(Atmt.FileName)

de save naam wordt zo opgebouwd: oudeFilenaam + attachmentCountNummer + extensie

dus bijvoorbeeld het tweede attachment genaamd "test.pdf" wordt gesaved als "test2.pdf"
volgens mij is de verzender's email adres in deze code: Item.Sender

Wil je de filenaam helemaal wegdoen of de sender toevoegen?

 

[koenschutte]

ik wil graag alleen het emailadres van de afzender hebben. als die al bestaat wil ik graag een (2) (3) erachter.

 

[wampier]

Dat laatste is een rol van windows, daar is via VBA weinig aan te doen, zonder zelf een volledige enumeratie te schrijven.

FileName = WheretosaveFolder & "\" & Item.Sender & I & "." & fso.GetExtensionName(Atmt.FileName)

Dit is de meest directe aanpassing van de bestaande code die ik kan bedenken, zonder een volledig extra enumeratie-systeem toe te voegen.

 

[snb]

Als je er zelf niets van snapt kun je beter geen VBA gebruiken, maar een deskundige inschakelen.

 

[koenschutte]

Als je er zelf niets van snapt kun je beter geen VBA gebruiken, maar een deskundige inschakelen.

Zoals ik het nu heb aangepakt kost niks, en ik ben zeer tevreden. Je opmerking is een beetje onnodig.

 

[koenschutte]

Dat laatste is een rol van windows, daar is via VBA weinig aan te doen, zonder zelf een volledige enumeratie te schrijven.

FileName = WheretosaveFolder & "\" & Item.Sender & I & "." & fso.GetExtensionName(Atmt.FileName)

Dit is de meest directe aanpassing van de bestaande code die ik kan bedenken, zonder een volledig extra enumeratie-systeem toe te voegen.

Super bedankt! hij heeft de documenten op deze wijze perfect aangepakt!
Ik krijg echter wel een error zodra er 2x dezelfde afzender tussen staat.

Is hier een simpele fix voor? misschien een bepaalde data meegeven? als we dan de documentnaam misschien ook de waarde meegegeven van de exacte tijd in milliseconden of iets anders wat mogelijk is.

Misschien heb jij hier nog een idee/oplossing voor?

Thanks in ieder geval! Het grootste probleem is al opgelost )

 

[wampier]

je kan de unieke ID van de mail of de Item.ReceivedTime gebruiken. Beetje afhankelijk hoe uniek het moet zijn (per dag / week /jaar)

zoiets toevoegen: maar dus afhankelijk van frequentie e.d. van je macro

& datediff ("s", Item.ReceivedTime, today() ) &