Visual Basic / VB.NET : Outlook vba sauvegarder le ou les fichiers joints d'une sélection de messages

Description

J'ai reçu 12 messages d'un même expéditeur avec pour chacun un fichier joint (une photo JPEG) donc j'ai sélectionné chacun des messages et enregistrer 12 fois le fichier joint.

La macro ne VBA ci dessous permet:

Après sélection multiple des messages à traiter, la macro en VBA permet de sélectionner un disque puis un dossier de sauvegarde et d'enregitrer les fichiers joints.

Source / Exemple :

Public disk As Integer, Chemin As String
'---------------------------------------------------------------------------------------------
'*** D'après un script publié par VBFRance (www.vbfrance.com)
Sub CopierFichierJoint()
        Dim OutlookApp As New Outlook.Application
        Dim OutlookExp As Outlook.Explorer
        Dim OutlookSélex As Outlook.Selection
        Dim x As Integer
        Dim i As Integer
        Dim NomFichier As String
        Dim NomFichierTemp As String
        Dim DossierDestination As String
        Dim DossierParDéfaut As String
        Dim DateRéception As String
        Dim fs
        'Procedure de traitement des messages
        Dim folder As String
        Set myOlApp = CreateObject("Outlook.Application")
        Set myNamespace = myOlApp.GetNamespace("MAPI")
        Set myfolder = myNamespace.GetDefaultFolder(olFolderInbox)
        
        ChoixDuDisk.Show
        Select Case disk
        Case 1
            Choix = ChoixDossierFichier("C:\")
        Case 2
            Choix = ChoixDossierFichier("J:\")
        Case 3
            On Error Resume Next
            Dir ("A:")
            If Err.Number = 52 Then
                MsgBox "Pas de disquette dans le lecteur, introduisez une disquette vierge dans le lecteur.", vbOKOnly, "Erreur"
                End
            End If
            Choix = ChoixDossierFichier("A:\")
            If Choix = "" Then Choix = "A:"
        End Select
        If Choix = "" Then End
        
        ChoixDuDisk.Hide

        DossierParDéfaut = Choix & "\"
        DossierDestination = DossierParDéfaut

        Set fs = CreateObject("Scripting.FileSystemObject")
        Set OutlookApp = CreateObject("Outlook.Application")
        Set OutlookExp = OutlookApp.ActiveExplorer
        Set OutlookSélex = OutlookExp.Selection
        If OutlookSélex.Count < 1 Then
            MsgBox "Aucun message n'est sélectionné.", vbExclamation, "Erreur"
            Exit Sub
        End If

        For x = 1 To OutlookSélex.Count
            DoEvents
            DateRéception = OutlookSélex.Item(x).ReceivedTime
            NomFichier = OutlookSélex.Item(x)
            NomFichier = NomFichier & " (" & DateRéception & ")"
            NomFichier = Remplacement(NomFichier, "/", ".")
            NomFichier = Remplacement(NomFichier, "\", "_")
            NomFichier = Remplacement(NomFichier, ":", ".")
            NomFichier = Remplacement(NomFichier, "*", "_")
            NomFichier = Remplacement(NomFichier, "?", "_")
            NomFichier = Remplacement(NomFichier, Chr(34), "_")
            NomFichier = Remplacement(NomFichier, "<", "_")
            NomFichier = Remplacement(NomFichier, ">", "_")
            NomFichier = Remplacement(NomFichier, "|", "_")
            i = 1
            NomFichierTemp = NomFichier

            On Error GoTo Erreur
            Set myItem = OutlookSélex.Item(x)
                If myItem.Attachments.Count > 0 Then
                    For pi = 1 To myItem.Attachments.Count
                        Set myAttachments = myItem.Attachments
                        'sauvegarde du piece attachee
                        myAttachments.Item(pi).SaveAsFile DossierDestination & "\" _
                        & myAttachments.Item(pi).DisplayName
                    Next
                Else
                    MsgBox "Le message " & NomFichier & " ne contient pas de fichier joint.", vbExclamation, "Erreur"
                End If
            
            Do While fs.FileExists(DossierDestination & NomFichier & ".msg") = True
                NomFichier = NomFichierTemp & " - " & i
                i = i + 1
            Loop
        Next x
        GoTo Fin
        End
Erreur:
        MsgBox "Le dossier que vous avez indiqué (" & DossierDestination & ") n'existe pas." _
        & Chr(10) & "Les messages n'ont pas été copiés.", vbOKOnly, "Erreur"
Fin:
End Sub

Function Remplacement(ByVal Texte As String, CarARemplacer As String, CarRemplacement As String) As String
    Dim c As Integer
    Do
        c = InStr(Texte, CarARemplacer)
        If c Then
            Texte = Left(Texte, c - 1) + CarRemplacement + Mid(Texte, c + Len(CarARemplacer))
        End If
    Loop While c
    Remplacement = Texte
End Function

Function ChoixDossierFichier(Racine, Optional SelType As Byte = 0)
Dim objShell, objFolder, Chemin, SecuriteSlash, FlagChoix&, Msg$

    If SelType = 0 Then
      FlagChoix = &H1&: Msg = "Choisissez un dossier :"
    Else
      FlagChoix = &H4000&: Msg = "Choisissez un fichier :"
    End If
    'modifier le chemin par défaut ci dessous

    'If disk = 1 Then Racine = "C:\Documents and Settings\ZiganPhil\Mes documents\ZIGAN"
    'If disk = 2 Then Racine = "J:\TELECHARGEMENT"
       
    Set objShell = CreateObject("Shell.Application")
    'le troisième paramètre permet de choisir
    'la sélection d'un dossier ou d'un fichier (0 ou 1)
    'le dernier paramètre permet de choisir le dossier racine
    Set objFolder = objShell.BrowseForFolder(&H0&, Msg, FlagChoix, Racine)
    On Error Resume Next
    Chemin = objFolder.ParentFolder.ParseName(objFolder.Title).Path & ""
    
    If Chemin = "" Then Exit Function
    If objFolder.Title = "Bureau" Then
        Chemin = "C:\Windows\Bureau"
    End If
    If objFolder.Title = "" Then
        Chemin = ""
    End If

    SecuriteSlash = InStr(objFolder.Title, ":")

    If SecuriteSlash > 0 Then
        Chemin = Mid(objFolder.Title, SecuriteSlash - 1, 2) & ""
    End If
    ChoixDossierFichier = Chemin

End Function

Télécharger le projet

Codes Sources

A voir également

Ajouter un commentaire

Commentaires

Signaler

cs_Acetilamino

Messages postés: 1
Date d'inscription: mardi 13 février 2007
Statut: Membre
Dernière intervention: 12 mai 2011

12 mai 2011 à 12:36

J'ai reçu plusieurs mails avec le même nom de fichier joint, ce qui avait pour incidence avec ce code d'écraser à chaque fois le fichier.
J'ai donc effectué cette modif (peut-être pas clean), mais qui semble fonctionner

On Error GoTo Erreur
Set myitem = OutlookSélex.Item(x)
If myitem.Attachments.Count > 0 Then
For pi = 1 To myitem.Attachments.Count
Set myAttachments = myitem.Attachments
'sauvegarde du piece attachee
' renomme
'Nom du fichier sans extension
Pos = InStr(1, myAttachments.Item(pi).FileName, ".", 1)
NomFichierSansExtension = Left(myAttachments.Item(pi).FileName, Pos - 1)
'Extension du fichier
Extension = Right(myAttachments.Item(pi).FileName, 3)
myAttachments.Item(pi).SaveAsFile DossierDestination & "" & NomFichierSansExtension & x & "." & Extension
FichierBon = True
Next
Else
MsgBox "Le message " & NomFichier & " ne contient pas de fichier joint.", vbExclamation, "Erreur"
End If

'Do While fs.FileExists(DossierDestination & NomFichier & ".msg") = True
' NomFichier = NomFichierTemp & " - " & i
' i = i + 1
'Loop

J'ai l'impression que la boucle ne fait pas bien son travail...

Signaler

zzj

Messages postés: 2
Date d'inscription: mercredi 16 mars 2005
Statut: Membre
Dernière intervention: 17 mars 2005

17 mars 2005 à 01:42

si multiples PJ sont download aussi!!!

très bien fait.

si on peut ajouter ses origines dans sa résumé (auteur, mot-clé, titre,...) de propriétés, c'est encore mieux

Signaler

Maniacfr

Messages postés: 22
Date d'inscription: vendredi 25 juillet 2003
Statut: Membre
Dernière intervention: 29 décembre 2008

18 févr. 2005 à 09:52

Il est dommage que vous n'ayez pas prévu les multiples pièces jointes.
J'ai déja un code permettant de le faire mais je n'avais jamais finalisé d'interface.
Je pense que je vais faire un mix des deux !
Bon courage !

Signaler

Maniacfr

Messages postés: 22
Date d'inscription: vendredi 25 juillet 2003
Statut: Membre
Dernière intervention: 29 décembre 2008

18 févr. 2005 à 09:52

Il est dommage que vous n'ayez pas prévu les multiples pièces jointes.
J'ai déja un code permettant de le faire mais je n'avais jamais finalisé d'interface.
Je pense que je vais faire un mix des deux !
Bon courage !

S'inscrire maintenant

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.

Outlook vba sauvegarder le ou les fichiers joints d'une sélection de messages

Description

Source / Exemple :

Codes Sources

A voir également

Commentaires

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Du même auteur (cs_philzig)

Macro en vba pour effacer les fichiers joints d'un ou plusieurs messages...

Source / Exemple :

A voir également

Vous n'êtes pas encore membre ? inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Du même auteur (cs_philzig)

Macro en vba pour effacer les fichiers joints d'un ou plusieurs messages...

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !