Outlook: Salvare Allegati in PDF in automatico e rinominarli

[Making]

Ciao e grazie come sempre.

A completamento di quanto ti ho chiesto in precedenza vorrei sapere se è possibile creare una macro in outlook (io uso 365) che salvi ogni giorno una ventina di allegati in pdf in una cartella chiamata PDF. I file mi arrivano sempre dalle stesse email ma a volte con nomi diversi per cui da ogni email devo scaricare il pdf sul PC e dargli sempre lo stesso nome. Ad esempio, l'email che mi arriva da Torino scaricherà il file che nominerà tor.pdf, quello di Milano mil.pdf ecc. Ad oggi ne ho circa una ventina al giorno ma potrebbero crescere quindi bisogna tenere conto anche di questo incremento che in qualche modo va' gestito.

Ho visto qualcosa nel forum ma si riferiva a file .xls. Infine, non so come si abilita, come si scrive e come si lanca la VBA su outlook, grazie in anticipo.

[Anthony47]

Una discussione molto simile alla tua e' questa:
viewtopic.php?f=26&t=110711
Quella soluzione scansiona tutte le mail contenute in un folder specificato, verifica che provenga da un certo mittente e che abbia un certo Subject; controlla se ha un allegato "pdf" ed eventualmente lo salva in un percorso indicato assegnandgli un nome in formato yyyy-mm-dd_timer.pdf; infine sposta l'email in un altro folder specificato.

Il modello vba di Outlook e' simile a quello di Excel (vedi viewtopic.php?f=26&t=103893&p=647675#p647675); accedi al progetto vba sempre tramite Alt-F11; la macro va inserita in un Modulo standard che va aggiunto tramite il comando Menu /Inserisci /Modulo

Per eseguirla puoi personalizzare la barra di accesso rapido di Outlook aggiungendogli una icona che avvii la tua macro, esattamente come descritto per Excel qui: viewtopic.php?f=26&t=103893&p=647679#p647679

Vedi dove arrivi, noi siamo qui

[Making]

Ciao grazie, devo dire che questa è più difficile. In ogni caso l'ho adattata alle mie cartelle e lanciandola si ferma all'istruzione "Set myMex = daProc.Items(J)" restituendo l'errore di run-time 13, Tipo non corrispondente. Cosa vuo, dire?

[Anthony47]

Vai in cima al codice; modifica quel myMex As MailItem in myMex as Variant

Ciao

[Making]

Grazie ho corretto. Mi sono inviato una mail l'allegato AAA.pdf che ho messo nella cartella "Sales".
Sembra girare tutto ma non sposta nulla, nel recap finale mi dice:

Completato ...
Messaggi esaminati: 1
Totale file salvati: 0
Messaggi esaminati ma non spostati: 1

Questa è la macro:

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 Variant
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("pippo@aaa.com").Folders("Sales")                           '<<<Folder di origine
Set Procd = myNameSpace.Folders("pippo@aaa.com").Folders("Vendite")        '<<< Folder di spostamento
BasePath = "C:\Prova\"   '<<< La directory di salvataggio allegati
'
PS = "\"
DayPath = Format(Now, "yyyy-mm-dd")
If Right(BasePath, 1) <> PS Then BasePath = BasePath & PS
'
tAdr = "pippo@"            '<<< Mittente
fTipo = ".pdf"                '<<< Tipo di file
tSubj = "Vendite"            '<<< 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

[Anthony47]

Modifica la macro come segue:

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 Variant
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("pippo@aaa.com").Folders("Sales")                           '<<<Folder di origine
Set Procd = myNameSpace.Folders("pippo@aaa.com").Folders("Vendite")        '<<< Folder di spostamento
BasePath = "C:\Prova\"   '<<< La directory di salvataggio allegati
'
PS = "\"
DayPath = Format(Now, "yyyy-mm-dd")
If Right(BasePath, 1) <> PS Then BasePath = BasePath & PS
'
tAdr = "pippo@"            '<<< Mittente
fTipo = ".pdf"                '<<< Tipo di file
tSubj = "Vendite"            '<<< Subject della mail
'
mTot = daProc.Items.Count
Debug.Print "A", mTot
For J = daProc.Items.Count To 1 Step -1
    Debug.Print ">>>"
    Set myMex = daProc.Items(J)
    flXls = False
    Debug.Print "B", J
    If TypeOf myMex Is MailItem Then
        Debug.Print "C", J, myMex.SenderName
        mSender = myMex.SenderName
        If InStr(1, mSender, tAdr, vbTextCompare) > 0 Then
            Debug.Print "D", J, "Pass"
            myTim = Timer
            AttCnt = myMex.Attachments.Count
            Debug.Print "E", J, AttCnt
            If AttCnt > 0 Then
                For I = 1 To AttCnt
                    AName = myMex.Attachments(I).DisplayName
                    Debug.Print "E" & I, J, AName
                    If UCase(Right(AName, Len(fTipo))) = UCase(fTipo) And _
                      InStr(1, myMex.Subject, tSubj, vbTextCompare) > 0 Then
                        Debug.Print "EE" & I, J, "Pass", flXls
                        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


Ho aggiunto la stampa di alcune informazioni di debug

Quando la macro si completa vai sul vba; apri la "Finestra Immediata" (premendo Contr-g dovrebbe aprirsi automaticamente); copia quanto vi e' scritto e pubblicalo nel tuo prox messaggio.
Attenzione: potrebbero esserci informazioni che preferisci tenere riservate; in questo caso sostituisci i caratteri che vuoi nascondere con * (asterisco) purche' il risultato sia intellegibile (un * ogni crt da nascondere)

Ciao

[Making]

A 1
Grazie, eccolo, fammi sapere.

Codice: Seleziona tutto

>>>
B              1
C              1            ****** ********
A              1
>>>
B              1
C              1            ****** ********

[Anthony47]

Allora...
Vedo che hai provato 2 volte
Il folder conteneva 1 solo messaggio
Il mittente e' ****** ********
Il mittente non quaglia con quanto hai scritto nella variabile tAdr (nel codice pubblicato c'e' scritto pippo@), quindi la mail viene ignorata e si passa alla prossima mail
Fine

Quindi la macro non riconosce il mittente come mittente dichiarato da intercettare e la mail viene ignorata
Devi guardare in quel ****** ******** per capire come dichiarare il mittente

Ciao

[Making]

Sistemata, forse cambiano il ome in **** non l'avevo cambiata ma si tratta dello stessoi indirizzo email. Continua a non funzionare.

[Anthony47]

Se continua a non funzionare e serve il mio aiuto mi devi mandare il nuovo log...

[Making]

A 1
>>>
B 1
C 1 xxx.xxxxxxxx@xxx.xx
A 1
>>>
B 1
C 1 xxx.xxxxxxxx@xxx.xx

[Anthony47]

Stessa storia:
La componente che scrivi in tAdr="xyzmn" non e' presente nell'indirizzo del mittente (xxx.xxxxxxxx@xxx.xx); la mail viene ignorata.

Guarda quel xxx.xxxxxxxx@xxx.xx e compila tAdr con lo stesso valore: tAdr = "xxx.xxxxxxxx"
Se vuoi ignorare in toto l'indirizzo del mittente usa tAdr="@"; oppure uso solo il domino, es tAdr="@ibm.com"

Ciao