Allora ho modificato la mail della discussione che ti avevo linkato per adattarla al tuo caso
La logica della macro e' la seguente:
-scansiona l'intero contenuto di Inbox; se trova una mail (a) proveniente da fi008c01 con (b) Subject contenente "Chiusura" allora (c) controlla se tra i suoi allegati ci sia un file pdf, e se Si allora salva il file e sposta la mail in una sottocartella di Inbox che supponiamo si chiami Chiusure. Il nome file usato sara' del tipo
yyyy-mm-dd_timer.pdf. Piu' file salvati con lo stesso yyyy-mm-dd avranno sempre "timer" diversi
-email che non rispettino le clausole a-b-c non saranno toccate
Il codice complessivo:
- Codice: Seleziona tutto
Sub WorkAllFrom()
'http://www.pc-facile.com/forum/viewtopic.php?f=26&t=110711&p=649928#p649928
Dim daProc As MAPIFolder, Procd As MAPIFolder
Dim myNameSpace As NameSpace, myMex As MailItem
Dim I As Long, BasePath As String, PS As String
Dim DayPath As String, J As Long, AttCnt As Long, mWAtt As Long, fCnt As Long, mTot As Long
Dim AName As String, myTim As Single, eDel As Single, flXls As Boolean, mRes As Long
Dim mSender, tAdr As String, fTipo As String
Dim bName As String, tSubj As String
'
Set myNameSpace = Application.GetNamespace("MAPI")
'
Set daProc = myNameSpace.Folders("Cartelle personali").Folders("Posta in arrivo") '<<<Folder di origine
Set Procd = myNameSpace.Folders("Cartelle personali").Folders("Posta in arrivo").Folders("Chiusure") '<<< Folder di spostamento
BasePath = "\\WK28VM01\Rep_cont\Outlets_Factory_Shop\CHIUSURE GIORNALIERE\2019\BARBE" '<<< La directory di salvataggio allegati
'
PS = "\"
DayPath = Format(Now, "yyyy-mm-dd")
If Right(BasePath, 1) <> PS Then BasePath = BasePath & PS
'
tAdr = "fi008c01@" '<<< Mittente
fTipo = ".PDF" '<<< Tipo di file
tSubj = "Chiusura" '<<< Subject della mail
'
mTot = daProc.Items.Count
For J = daProc.Items.Count To 1 Step -1
Set myMex = daProc.Items(J)
flXls = False
If TypeOf myMex Is MailItem Then
mSender = myMex.SenderName
If InStr(1, mSender, tAdr, vbTextCompare) > 0 Then
myTim = Timer
AttCnt = myMex.Attachments.Count
If AttCnt > 0 Then
For I = 1 To AttCnt
AName = myMex.Attachments(I).DisplayName
If UCase(Right(AName, Len(fTipo))) = UCase(fTipo) And _
InStr(1, myMex.Subject, tSubj, vbTextCompare) > 0 Then
bName = DayPath & "_" & Format(Timer, "00000") & fTipo
'se file PDF, salva allegato:
fCnt = fCnt + 1
myMex.Attachments(I).SaveAsFile BasePath & bName
flXls = True
'eventuale attesa per >1 sec:
If (Timer - myTim) < 1 Then
eDel = (myTim + 1.5 - Timer)
myWait (eDel)
End If
End If
Next I
End If
If flXls Then mWAtt = mWAtt + 1
'Sposta messaggio:
myMex.Move Procd
End If
End If
Next J
mRes = daProc.Items.Count 'Itm residui (non mailItems)
MsgBox ("Completato... " & vbCrLf & "Messaggi esaminati: " & mTot _
& vbCrLf & "Mail (spostate) con allegati: " & mWAtt _
& vbCrLf & "Totale file salvati: " & fCnt _
& vbCrLf & "Messaggi esaminati ma non spostati: " & mRes)
End Sub
Sub myWait(ByVal myStab As Single)
Dim myStTiM As Single
'
myStTiM = Timer
Do 'wait myStab
DoEvents
If Timer > myStTiM + myStab Or Timer < myStTiM Then Exit Do
Loop
End Sub
Va messo tutto in un "modulo standard" del vba Outlook.
Le righe marcate <<< vanno personalizzate con i tuoi dati, come da commento.
Se hai dei dubbi su quali siano i nomi di folder e subfolder presenti nel tuo albero, nella discussione gia' linkata (in particolare, vedi
viewtopic.php?f=26&t=109180#p642336) trovi il codice della
Sub folderTree che ti aiutera' a capire la struttura del tuo albero.
Poi all'occorrenza va lanciata la Sub WorkAllFrom
Eventualmente inserisci nella Barra di Accesso Rapido di Outlook un richiamo alla macro, in modo da eseguirla piu' facilmente
Ripeto che la macro scansiona tutto il folder dichiarato in
Set daProc alla ricerca di email con i requisiti a-b-c citati all'inizio. Poiche' Outlook non garantisce che tutte le mail in arrivo siano processate dalle eventuali regole, scansionare l'intero folder di arrivo e' inevitabile.
Spero sia di qualche utilita'...
Registrazione
