m salva allegati email

Attribute VB_Name = "m_salva_allegati_email"

'

Option Explicit



'



' vba - Outlook 2002

' salva gli allegati delle email selezionate.

'

Public Sub SalvaAllegatiEmail()

'

Dim objOL As Outlook.Application

Dim objMsg As Object, archivio

Dim objAttachments As Outlook.Attachments

Dim objSelection As Outlook.Selection

Dim i As Long

Dim lngCount As Long, domanda As String

Dim strFile As String

Dim strFolder As String

Dim soggetto

'

Dim fs, esiste As Boolean, tentativi As Integer

Set fs = CreateObject("Scripting.FileSystemObject")

'

On Error Resume Next

' Crea oggetto Outlook Application.

Set objOL = CreateObject("Outlook.Application")

' riferimento messaggi selezionati.

Set objSelection = objOL.ActiveExplorer.Selection

' strFolder = Application.GetOpenFilename("Tutti i file (*.*), *.*")

' scelta della cartella dove salvare gli allegati

strFolder = InputBox("scelta cartella", "scelta cartella", "c:\allegati-posta")

If strFolder = "" Then

MsgBox "cartella non trovata!", vbOKOnly

GoTo ExitSub

End If

'

strFolder = strFolder & "\"

'

Dim style

style = vbYesNo + vbCritical + vbDefaultButton2 ' Definisce i pulsanti.

domanda = MsgBox("cancello allegati?", style, "scelta") ' scelta se cancellare gli allegati dopo il salvataggio

'

For Each objMsg In objSelection ' ciclo su tutti i messaggi

tentativi = 0

' serve per i messaggi nelle cartelle pubbliche o private

If objMsg.Class = 43 Or objMsg.Class = 45 Then

' riferimento agli allegati

Set objAttachments = objMsg.Attachments

'

'''MsgBox objMsg.HTMLBody

'

'MsgBox objMsg.Subject

'MsgBox "allegati: " & objAttachments.Count

lngCount = objAttachments.Count ' conteggio del numero di allegati

If lngCount > 0 Then

' ciclo su tutti gli allegati del messaggio.

For i = lngCount To 1 Step -1

' strFile = objAttachments.Item(i).FileName

soggetto = objMsg.Subject ' oggetto del messaggio

' MsgBox soggetto

' sostituisce i caratteri no utilizzabili nel nome di un file

soggetto = Replace(soggetto, "/", "-")

soggetto = Replace(soggetto, ".", "_")

soggetto = Replace(soggetto, "I:", "")

soggetto = Replace(soggetto, "I:", "")

soggetto = Replace(soggetto, ":", "")

'strFile = objAttachments.Item(i).FileName

' crea il mome del file - concatena oggetto del messaggio con il nome del file

strFile = soggetto & "-" & objAttachments.Item(i).FileName

archivio = strFile

' MsgBox strFile

' crea il percorso di salvataggio allegato.

strFile = strFolder & strFile

' verifica se esiste un file con il medesimo nome

esiste = fs.FileExists(strFile)

' MsgBox esiste

'

While esiste = True ' nel caso esista lo stesso nome del file incrementa il contatore

tentativi = tentativi + 1

strFile = strFolder & objMsg.Subject & "-allegato-" & tentativi & archivio

esiste = fs.FileExists(strFile)

Wend

' salva allegato.

objAttachments.Item(i).SaveAsFile strFile

'

If domanda = vbYes Then ' nel caso si sia scelto di cancellare gli allegati.

' cancella allegato.

objAttachments.Item(i).Delete

End If

'



Next i

End If

objMsg.Save

End If

Next

'

ExitSub:

Set objAttachments = Nothing

Set objMsg = Nothing

Set objSelection = Nothing

Set objOL = Nothing

'

End Sub