Potresti usare questa macro, che scarica tutti gli allegati delle mail presenti in un certo folder di Outlook, rinominandoli con un prefisso che contiene la data/ora di ricezione messaggio + data/ora corrente + email del sender, oltre al nome file dell'allegato. Infine i messaggi vengono spostati in un altro folder per evitare scaricamenti multipli.
- Codice: Seleziona tutto
Sub WorkAllPref()
'Salva allegato con prefisso
'Vedi http://www.pc-facile.com/forum/viewtopic.php?f=26&t=110162
Dim daProc As MAPIFolder, Procd As MAPIFolder
Dim myNameSpace As NameSpace, myMex As MailItem, mMitt As String
Dim ZZsjAdd As String, ZZMailTxt As String, 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, mySplit, myTim As Single, eDel As Single, mRes As Long
Dim mSender, noBB As String, uniqHdr As String
'
Set myNameSpace = Application.GetNamespace("MAPI")
'
'QUESTE TRE RIGHE SONO LE IMPOSTAZIONI:
Set daProc = myNameSpace.Folders("Cartelle personali").Folders("Posta in arrivo").Folders("_DaProcessare") '<<<Folder di origine
Set Procd = myNameSpace.Folders("Cartelle personali").Folders("Posta in arrivo").Folders("_Processate") '<<< Folder di destinazione
BasePath = "C:\PROVA" '<<< La directory "base" in cui saranno salvati gli allegati
'
'Inizio esame messaggi:
noBB = "<>:/\|?*" & Chr(34)
PS = "\"
If Right(BasePath, 1) <> PS Then BasePath = BasePath & PS
DayPath = BasePath
mTot = daProc.Items.Count
'Esamina le mail presenti:
For J = daProc.Items.Count To 1 Step -1
Set myMex = daProc.Items(J)
' flXls = False
If TypeOf myMex Is MailItem Then
rtime = myMex.ReceivedTime
uniqHdr = Format(myMex.ReceivedTime, "yyyy-mm-dd_hh-mm-ss") & "_" & Format(Now, "mm-dd-hhmmss") & "_"
mSender = myMex.SenderEmailAddress & "_"
'bonifica Adr:
For I = 1 To Len(noBB)
mSender = Replace(mSender, Mid(noBB, I, 1), "#", , , vbTextCompare)
Next I
myTim = Timer
AttCnt = myMex.Attachments.Count
If AttCnt > 0 Then
For I = 1 To AttCnt
'Sistema il nome file:
AName = uniqHdr & mSender & myMex.Attachments(I).DisplayName
'salva allegato:
fCnt = fCnt + 1
myMex.Attachments(I).SaveAsFile DayPath & PS & AName
Next I
Else
'Niente?
End If
' 'Modifica Subject mail "lavorata":
' myMex.Subject = uniqHdr & myMex.Subject
' myMex.Save
mWAtt = mWAtt + 1
'Sposta messaggio:
myMex.Move Procd
'eventuale attesa per >1 sec:
If (Timer - myTim) < 1 Then
eDel = (myTim + 1.5 - Timer)
myWait (eDel)
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 allegati: " & fCnt _
& vbCrLf & "Messaggi rimanenti (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
Il codice va messo in un nuovo modulo standard del vba di Outlook.
Le righe marcate <<< vanno personalizzate come da commento
I folder dove si guardera' ("DaProcessare", nel codice proposto) e dove i messaggi verrano spostati ("_Processate", nel codice) devono gia' esistere; idem la directory di salvataggio degli allegati
All'occorrenza poi va lanciata la Sub WorkAllPref (puoi usare Alt-F8, oppure assegnarlaa una icona nella barra di accesso rapido, o usare una delle possibili altre alternative)
Prova e fai sapere...