Domanda Script per stampa allegati su Outlook, in VBA

ugidj

Utente junior
6 Giugno 2018
39
8
Vicenza
Prof. Plus 2016
0
Gentili tutti,

sento di essere giusto un pelino off-topic ma vorrei porre comunque un quesito riguardo il seguente codice VBA (penso) reperito in rete:

Visual Basic:
Sub Stampa_fatture()

Dim xFSO As Scripting.FileSystemObject
Dim xTmpFldPath As String
Dim xSelection As Outlook.Selection
Dim xItem As Object
Dim xMailItem As Outlook.MailItem
Dim xAttachments As Outlook.attachments
Dim xAttachment As Outlook.Attachment
Dim xShell As Object
Dim xTempFolder As Object
Dim xTempFolderItem As Object
Dim xFilePath As String
On Error Resume Next
Set xFSO = CreateObject("Scripting.FileSystemObject")
xTmpFldPath = xFSO.GetSpecialFolder(2).Path & "\Temp for Attachments"
If xFSO.FolderExists(xTmpFldPath) = False Then
    xFSO.CreateFolder xTmpFldPath
End If
Set xSelection = Outlook.Application.ActiveExplorer.Selection
Set xShell = CreateObject("Shell.Application")
Set xTempFolder = xShell.NameSpace(0)
For Each xItem In xSelection
    If xItem.Class = olMail Then
        Set xMailItem = xItem
        If xMailItem.attachments.Count = 0 Then Exit Sub
        Set xAttachments = xMailItem.attachments
        For Each xAttachment In xAttachments
            xFilePath = xTmpFldPath & "\" & xAttachment.FileName
            xAttachment.SaveAsFile (xFilePath)
            Set xTempFolderItem = xTempFolder.ParseName(xFilePath)
            xTempFolderItem.InvokeVerbEx ("print")
        Next
    End If
Next

'If xFSO.FolderExists(xTmpFldPath) Then
'    xFSO.DeleteFolder xTmpFldPath, True
'End If
End Sub
In buona sostanza ricevo quotidianamente delle email con circa 15/20 allegati esclusivamente PDF che devo stampare (solamente stampare, evitandomi la scocciatura di salvarmeli in una cartella temporaneamente), e il codice qui sopra, una volta integrato in Outlook, mi permette effettivamente di stampare con un clic tutte quelle fatture.. (Per poterlo far funzionare ho dovuto abilitare Microsoft Scripting Runtime da Strumenti --> Riferimenti.)

Ora mi piacerebbe fare in modo che stampasse seguendo l'ordine alfabetico dei nomi file allegati, perché al momento stampa in un ordine un tantino "casuale" Stranito_pazzo

Qualche gentilissima anima pia saprebbe aiutarmi nel capire dove apportare modifiche al codice di modo che stampi in ordine alfabetico crescente?

Grazie mille a tutti
E tanti auguri di buone feste ??
Eugenio
 

prrpql

Utente junior
16 Maggio 2018
23
1
sessa aurunca
2010
0
Gentili tutti,

sento di essere giusto un pelino off-topic ma vorrei porre comunque un quesito riguardo il seguente codice VBA (penso) reperito in rete:

Visual Basic:
Sub Stampa_fatture()

Dim xFSO As Scripting.FileSystemObject
Dim xTmpFldPath As String
Dim xSelection As Outlook.Selection
Dim xItem As Object
Dim xMailItem As Outlook.MailItem
Dim xAttachments As Outlook.attachments
Dim xAttachment As Outlook.Attachment
Dim xShell As Object
Dim xTempFolder As Object
Dim xTempFolderItem As Object
Dim xFilePath As String
On Error Resume Next
Set xFSO = CreateObject("Scripting.FileSystemObject")
xTmpFldPath = xFSO.GetSpecialFolder(2).Path & "\Temp for Attachments"
If xFSO.FolderExists(xTmpFldPath) = False Then
    xFSO.CreateFolder xTmpFldPath
End If
Set xSelection = Outlook.Application.ActiveExplorer.Selection
Set xShell = CreateObject("Shell.Application")
Set xTempFolder = xShell.NameSpace(0)
For Each xItem In xSelection
    If xItem.Class = olMail Then
        Set xMailItem = xItem
        If xMailItem.attachments.Count = 0 Then Exit Sub
        Set xAttachments = xMailItem.attachments
        For Each xAttachment In xAttachments
            xFilePath = xTmpFldPath & "\" & xAttachment.FileName
            xAttachment.SaveAsFile (xFilePath)
            Set xTempFolderItem = xTempFolder.ParseName(xFilePath)
            xTempFolderItem.InvokeVerbEx ("print")
        Next
    End If
Next

'If xFSO.FolderExists(xTmpFldPath) Then
'    xFSO.DeleteFolder xTmpFldPath, True
'End If
End Sub
In buona sostanza ricevo quotidianamente delle email con circa 15/20 allegati esclusivamente PDF che devo stampare (solamente stampare, evitandomi la scocciatura di salvarmeli in una cartella temporaneamente), e il codice qui sopra, una volta integrato in Outlook, mi permette effettivamente di stampare con un clic tutte quelle fatture.. (Per poterlo far funzionare ho dovuto abilitare Microsoft Scripting Runtime da Strumenti --> Riferimenti.)

Ora mi piacerebbe fare in modo che stampasse seguendo l'ordine alfabetico dei nomi file allegati, perché al momento stampa in un ordine un tantino "casuale" Stranito_pazzo

Qualche gentilissima anima pia saprebbe aiutarmi nel capire dove apportare modifiche al codice di modo che stampi in ordine alfabetico crescente?

Grazie mille a tutti
E tanti auguri di buone feste ??
Eugenio
ciao,
ho il tuo stesso problema la macro funziona però, sai se è possibile far stampare in automatico all'arrivo della email in una determinata cartella?
 

ges

Excel/VBA Expert
Amministratore
Expert
21 Giugno 2015
22.622
1.733
Como
2011MAC 2016WIN
510
P @prrpql per la tua richiesta devi aprire una nuova discussione
 

rollis13

Utente assiduo
15 Novembre 2015
1.608
63
Cordenons
Office 2016 x64
83
Vedi se la tua macro così rivisitata con l'aggiunta di matrice per contenere e riordinare gli allegati ti può andar bene.
Per il riordino ho sfruttato una macro trovata già pronta in rete e che ho già utilizzato altre volte con successo. E' un semplice bubblesort che va benissimo per non troppi elementi.
Chiaramente, come prima, è necessario che Outlook sia già aperto al momento del lancio della macro e sia aperto su una cartella contenente almeno una email altrimenti c'è da implementare altro codice per il controllo degli errori.
Visual Basic:
Option Explicit

Sub Stampa_fatture()
    Dim xFSO   As Scripting.FileSystemObject
    Dim xTmpFldPath As String
    Dim xSelection As Outlook.Selection
    Dim xItem  As Object
    Dim xMailItem As Outlook.MailItem
    Dim xAttachments As Outlook.Attachments
    Dim xAttachment As Outlook.Attachment
    Dim xShell As Object
    Dim xTempFolder As Object
    Dim xTempFolderItem As Object
    Dim xFilePath As String
    Dim n      As Long
    Dim lista  As Variant
    Dim ciclo  As Long

    'On Error Resume Next
    On Error GoTo uscita
    Set xFSO = CreateObject("Scripting.FileSystemObject")
    xTmpFldPath = xFSO.GetSpecialFolder(2).Path & "\Temp for Attachments"
    If xFSO.FolderExists(xTmpFldPath) = False Then
        xFSO.CreateFolder xTmpFldPath
    End If
    Set xSelection = Outlook.Application.ActiveExplorer.Selection
    Set xShell = CreateObject("Shell.Application")
    Set xTempFolder = xShell.Namespace(0)
    For Each xItem In xSelection
        If xItem.Class = olMail Then
            Set xMailItem = xItem
            If xMailItem.Attachments.Count = 0 Then
                MsgBox "Non ci sono allegati da stampare"
                GoTo uscita
            End If
            Set xAttachments = xMailItem.Attachments
            ReDim lista(xAttachments.Count - 1)   'dimensiona la matrice in base al numero di allegati
            n = 0                                 'contatore per allegati
            For Each xAttachment In xAttachments
                xFilePath = xTmpFldPath & "\" & xAttachment.Filename
                xAttachment.SaveAsFile (xFilePath) 'salva l'allegato tra i file temporanei
                lista(n) = xAttachment.Filename   'popola la matrice con i nomi degli allegati
                n = n + 1
            Next
            Call BubbleSort(lista)                'riordina la matrice
            For ciclo = 0 To UBound(lista)        'ciclo sugli allegati presenti
                xFilePath = xTmpFldPath & "\" & lista(ciclo)
                Set xTempFolderItem = xTempFolder.ParseName(xFilePath)
                xTempFolderItem.InvokeVerbEx ("Print")
            Next ciclo
        End If
    Next
uscita:
    Set xFSO = Nothing
    Set xSelection = Nothing
    Set xShell = Nothing
    Set xTempFolder = Nothing
    Set xMailItem = Nothing
    Set xAttachments = Nothing
    Set xTempFolderItem = Nothing
 
End Sub

Sub BubbleSort(lista)

    Dim strTemp As String
    Dim i      As Long
    Dim j      As Long
    Dim lngMin As Long
    Dim lngMax As Long

    lngMin = LBound(lista)
    lngMax = UBound(lista)
    For i = lngMin To lngMax
        For j = i + 1 To lngMax
            If lista(i) > lista(j) Then
                strTemp = lista(i)
                lista(i) = lista(j)
                lista(j) = strTemp
            End If
        Next j
    Next i
  
End Sub
 

prrpql

Utente junior
16 Maggio 2018
23
1
sessa aurunca
2010
0
la
Gentili tutti,

sento di essere giusto un pelino off-topic ma vorrei porre comunque un quesito riguardo il seguente codice VBA (penso) reperito in rete:

Visual Basic:
Sub Stampa_fatture()

Dim xFSO As Scripting.FileSystemObject
Dim xTmpFldPath As String
Dim xSelection As Outlook.Selection
Dim xItem As Object
Dim xMailItem As Outlook.MailItem
Dim xAttachments As Outlook.attachments
Dim xAttachment As Outlook.Attachment
Dim xShell As Object
Dim xTempFolder As Object
Dim xTempFolderItem As Object
Dim xFilePath As String
On Error Resume Next
Set xFSO = CreateObject("Scripting.FileSystemObject")
xTmpFldPath = xFSO.GetSpecialFolder(2).Path & "\Temp for Attachments"
If xFSO.FolderExists(xTmpFldPath) = False Then
    xFSO.CreateFolder xTmpFldPath
End If
Set xSelection = Outlook.Application.ActiveExplorer.Selection
Set xShell = CreateObject("Shell.Application")
Set xTempFolder = xShell.NameSpace(0)
For Each xItem In xSelection
    If xItem.Class = olMail Then
        Set xMailItem = xItem
        If xMailItem.attachments.Count = 0 Then Exit Sub
        Set xAttachments = xMailItem.attachments
        For Each xAttachment In xAttachments
            xFilePath = xTmpFldPath & "\" & xAttachment.FileName
            xAttachment.SaveAsFile (xFilePath)
            Set xTempFolderItem = xTempFolder.ParseName(xFilePath)
            xTempFolderItem.InvokeVerbEx ("print")
        Next
    End If
Next

'If xFSO.FolderExists(xTmpFldPath) Then
'    xFSO.DeleteFolder xTmpFldPath, True
'End If
End Sub
In buona sostanza ricevo quotidianamente delle email con circa 15/20 allegati esclusivamente PDF che devo stampare (solamente stampare, evitandomi la scocciatura di salvarmeli in una cartella temporaneamente), e il codice qui sopra, una volta integrato in Outlook, mi permette effettivamente di stampare con un clic tutte quelle fatture.. (Per poterlo far funzionare ho dovuto abilitare Microsoft Scripting Runtime da Strumenti --> Riferimenti.)

Ora mi piacerebbe fare in modo che stampasse seguendo l'ordine alfabetico dei nomi file allegati, perché al momento stampa in un ordine un tantino "casuale" Stranito_pazzo

Qualche gentilissima anima pia saprebbe aiutarmi nel capire dove apportare modifiche al codice di modo che stampi in ordine alfabetico crescente?

Grazie mille a tutti
E tanti auguri di buone feste ??
Eugenio
la macro ha funzionato la prima volta adesso mi stampa la mail ma non l'allegato ....ho cancellato la macro ma continua stampare :(
 

ugidj

Utente junior
6 Giugno 2018
39
8
Vicenza
Prof. Plus 2016
0
Vedi se la tua macro così rivisitata con l'aggiunta di matrice per contenere e riordinare gli allegati ti può andar bene.
Per il riordino ho sfruttato una macro trovata già pronta in rete e che ho già utilizzato altre volte con successo. E' un semplice bubblesort che va benissimo per non troppi elementi.
Chiaramente, come prima, è necessario che Outlook sia già aperto al momento del lancio della macro e sia aperto su una cartella contenente almeno una email altrimenti c'è da implementare altro codice per il controllo degli errori.
Visual Basic:
Option Explicit

Sub Stampa_fatture()
    Dim xFSO   As Scripting.FileSystemObject
    Dim xTmpFldPath As String
    Dim xSelection As Outlook.Selection
    Dim xItem  As Object
    Dim xMailItem As Outlook.MailItem
    Dim xAttachments As Outlook.Attachments
    Dim xAttachment As Outlook.Attachment
    Dim xShell As Object
    Dim xTempFolder As Object
    Dim xTempFolderItem As Object
    Dim xFilePath As String
    Dim n      As Long
    Dim lista  As Variant
    Dim ciclo  As Long

    'On Error Resume Next
    On Error GoTo uscita
    Set xFSO = CreateObject("Scripting.FileSystemObject")
    xTmpFldPath = xFSO.GetSpecialFolder(2).Path & "\Temp for Attachments"
    If xFSO.FolderExists(xTmpFldPath) = False Then
        xFSO.CreateFolder xTmpFldPath
    End If
    Set xSelection = Outlook.Application.ActiveExplorer.Selection
    Set xShell = CreateObject("Shell.Application")
    Set xTempFolder = xShell.Namespace(0)
    For Each xItem In xSelection
        If xItem.Class = olMail Then
            Set xMailItem = xItem
            If xMailItem.Attachments.Count = 0 Then
                MsgBox "Non ci sono allegati da stampare"
                GoTo uscita
            End If
            Set xAttachments = xMailItem.Attachments
            ReDim lista(xAttachments.Count - 1)   'dimensiona la matrice in base al numero di allegati
            n = 0                                 'contatore per allegati
            For Each xAttachment In xAttachments
                xFilePath = xTmpFldPath & "\" & xAttachment.Filename
                xAttachment.SaveAsFile (xFilePath) 'salva l'allegato tra i file temporanei
                lista(n) = xAttachment.Filename   'popola la matrice con i nomi degli allegati
                n = n + 1
            Next
            Call BubbleSort(lista)                'riordina la matrice
            For ciclo = 0 To UBound(lista)        'ciclo sugli allegati presenti
                xFilePath = xTmpFldPath & "\" & lista(ciclo)
                Set xTempFolderItem = xTempFolder.ParseName(xFilePath)
                xTempFolderItem.InvokeVerbEx ("Print")
            Next ciclo
        End If
    Next
uscita:
    Set xFSO = Nothing
    Set xSelection = Nothing
    Set xShell = Nothing
    Set xTempFolder = Nothing
    Set xMailItem = Nothing
    Set xAttachments = Nothing
    Set xTempFolderItem = Nothing

End Sub

Sub BubbleSort(lista)

    Dim strTemp As String
    Dim i      As Long
    Dim j      As Long
    Dim lngMin As Long
    Dim lngMax As Long

    lngMin = LBound(lista)
    lngMax = UBound(lista)
    For i = lngMin To lngMax
        For j = i + 1 To lngMax
            If lista(i) > lista(j) Then
                strTemp = lista(i)
                lista(i) = lista(j)
                lista(j) = strTemp
            End If
        Next j
    Next i
 
End Sub
Gentilissimo rollis13 @rollis13 , ti ringrazio tanto per il super tentativo di aiuto! Purtroppo però la macro continua a stampare gli allegati in ordine casuale :confusostelle:
Non ho proprio idea di che tipo di modifiche potrebbero aiutarmi ad ottenere il risultato voluto, e ho tanta paura che mi toccherà rinunciare..
Hai qualche idea sul perché l'ordine resti comunque casuale?

Grazie mille ancora
Un caro saluto a tutti
Eugenio
 

rollis13

Utente assiduo
15 Novembre 2015
1.608
63
Cordenons
Office 2016 x64
83
Se hai inteso il funzionamento delle modifiche che ho apportato la tua domanda risulterebbe 'impossibile' perché si è trattato solamente di rilevare tutti i nome degli allegati presenti nell'email, caricarli in una matrice, riordinare la matrice ed in fine stampare tutti gli allegati così ordinati.
Tutto quello che mi viene in mente è che i nomi degli allegati non sono così 'normali' (alfabeticamente parlando).
Dovresti allegare diversi esempi di nomi degli allegati che si possono trovare.

Tagliamo la testa al toro; ho inserito nella macro il riepilogo dei nomi prima e dopo il riordino così da verificare se viene eseguito il bubblesort e cosa si ottiene come risultato.
Ti allego la macro modificata (senza stampa attiva):
Visual Basic:
Option Explicit

Sub Stampa_fatture()

    Dim xFSO   As Scripting.FileSystemObject
    Dim xTmpFldPath As String
    Dim xSelection As Outlook.Selection
    Dim xItem  As Object
    Dim xMailItem As Outlook.MailItem
    Dim xAttachments As Outlook.Attachments
    Dim xAttachment As Outlook.Attachment
    Dim xShell As Object
    Dim xTempFolder As Object
    Dim xTempFolderItem As Object
    Dim xFilePath As String
    Dim n      As Integer
    Dim lista  As Variant
    Dim ciclo  As Integer

    'On Error Resume Next
    On Error GoTo uscita
    Set xFSO = CreateObject("Scripting.FileSystemObject")
    xTmpFldPath = xFSO.GetSpecialFolder(2).Path & "\Temp for Attachments"
    If xFSO.FolderExists(xTmpFldPath) = False Then
        xFSO.CreateFolder xTmpFldPath
    End If
    Set xSelection = Outlook.Application.ActiveExplorer.Selection
    Set xShell = CreateObject("Shell.Application")
    Set xTempFolder = xShell.Namespace(0)
    For Each xItem In xSelection
        If xItem.Class = olMail Then
            Set xMailItem = xItem
            If xMailItem.Attachments.Count = 0 Then
                MsgBox "Non ci sono allegati da stampare"
                GoTo uscita
            End If
            Set xAttachments = xMailItem.Attachments
            ReDim lista(xAttachments.Count - 1)   'dimensiona la matrice in base al numero di allegati
            n = 0                                 'contatore per allegati
            For Each xAttachment In xAttachments
                xFilePath = xTmpFldPath & "\" & xAttachment.Filename
                xAttachment.SaveAsFile (xFilePath) 'salva l'allegato tra i file temporanei
                lista(n) = xAttachment.Filename   'popola la matrice con i nomi degli allegati
                n = n + 1
            Next
            '============== INIZIO TEST =================================================
            Dim test, msg
            msg = "Prima:" & vbLf
            For test = 0 To UBound(lista)
                msg = msg & lista(test) & vbLf
            Next test
            MsgBox msg                            'mostra lista nomi così come prelevati dall'email
          
            Call BubbleSort(lista)                'riordina la matrice
          
            msg = "Dopo:" & vbLf
            For test = 0 To UBound(lista)
                msg = msg & lista(test) & vbLf
            Next test
            MsgBox msg                            'mostra lista nomi ordinati
            '============== FINE TEST ==================================================
            '            For ciclo = 0 To UBound(lista)        'ciclo sugli allegati presenti
            '                xFilePath = xTmpFldPath & "\" & lista(ciclo)
            '                Set xTempFolderItem = xTempFolder.ParseName(xFilePath)
            '                xTempFolderItem.InvokeVerbEx ("Print")
            '            Next ciclo
        End If
    Next
uscita:
    Set xFSO = Nothing
    Set xSelection = Nothing
    Set xShell = Nothing
    Set xTempFolder = Nothing
    Set xMailItem = Nothing
    Set xAttachments = Nothing
    Set xTempFolderItem = Nothing
  
End Sub

Sub BubbleSort(lista)

    Dim strTemp As String
    Dim i      As Long
    Dim j      As Long
    Dim lngMin As Long
    Dim lngMax As Long

    lngMin = LBound(lista)
    lngMax = UBound(lista)
    For i = lngMin To lngMax
        For j = i + 1 To lngMax
            If lista(i) > lista(j) Then
                strTemp = lista(i)
                lista(i) = lista(j)
                lista(j) = strTemp
            End If
        Next j
    Next i
  
End Sub
 

Sostieni ForumExcel

Aiutaci a sostenere le spese e a mantenere online la community attraverso una libera donazione!