ENREGISTRER DES PIECES JOINTES DE MESSAGE D'UN DOSSIER COURANT DANS UN REPERTOIRE PRECIS (OUTLOOK)

Global ActionFrm               As Integer
Sub exporter()

Dim chemin As String                'chemin où seront enregistrés les messages
Dim myOlApp As Application          'correspond à l'application Outlook
Dim Expl As Explorer                'correspond à l'explorer utilisé par l'utilisateur
Dim myNameSpace As NameSpace        'représente un objet racine abstrait pour un type de source de données quelconque
Dim myFolder As MAPIFolder          'correspond au dossier courant
Dim myItems As Items                'correspond aux messages du dossier courant
Dim xi As Integer                   'Indice de parcours
Dim xj As Integer                   'Indice de parcours
Dim myAttachments As Attachments    'correspond à toutes les pièces jointes
Dim nomFichier As String            'nom des futurs messages enregistrés

'Activation du formulaire sans l'afficher
Load sauvegarde_PJ

'Initialisation du champs chemin
sauvegarde_PJ.TextBox1.Value = ""
sauvegarde_PJ.TextBox1.SetFocus

'Ouverture du formulaire
sauvegarde_PJ.Show

    
If ActionFrm = vbOK Then
    
    'On recupère le chemin donné par l'utilisateur
    chemin = sauvegarde_PJ.TextBox1.Value
    
    'On rajoute un \ s'il n'est pas présent à la fin du chemin
    If (Right(chemin, 1) <> "\") Then
        chemin = chemin & "\"
    End If
    
    'Test de validité du champs
    'Tant que l'utilisateur clique sur le bouton OK
    'et que le test n'est pas valide
    Do While ((ActionFrm = vbOK) And ((chemin = "") Or (Dir(chemin) = "")))
    
        'Message indiquant que le champs est vide
        'ou le chemin est inexistant
        'Retour au formulaire
        MsgBox "Le chemin est inexistant ou le champs est vide", vbOKOnly, "Erreur"
        
        'Réinitialise la valeur
        sauvegarde_PJ.TextBox1.Value = ""
        sauvegarde_PJ.TextBox1.SetFocus
        
        'Réaffiche le formulaire
        sauvegarde_PJ.Show
        
        'Récupération de la valeur
        chemin = sauvegarde_PJ.TextBox1.Value
    
        'Rajout de \ si non présent
        If (Right(chemin, 1) <> "\") Then
            chemin = chemin & "\"
        End If
        
    Loop
    
    'Soit l'utilisateur a cliqué sur CANCEL (sorti de l'application, fin du programme)
    'Soit les tests sont valides
    If (ActionFrm = vbOK) Then
        
        Set myOlApp = CreateObject("Outlook.Application")

        'Expl nous donne le dossier courant
        'Boîte de reception, d'envoi, brouillons, ...
        Set Expl = ActiveExplorer

        'Permet d'accéder à toutes les données Outlook qui y sont stockées
        Set myNameSpace = myOlApp.GetNamespace("MAPI")
    
        'On recupère l'ID du dossier courant puis on se positionne dans ce dossier
        'pour recupérer tous les messages
        Set myFolder = myNameSpace.GetFolderFromID(Expl.CurrentFolder.EntryID)
        
        'La variable myItems prendra comme valeur
        'tous les messages du dossier courant
        Set myItems = myFolder.Items


        'On parcourt myItems et
        'pour chaque valeur on sauvegarde la pièce jointe si elle existe
        For xi = 1 To myItems.Count
        
            'On regarde s'il existe des pièces jointes
            'si oui on fait les sauvegardes
            'sinon on passe au message suivant
            If myItems.Item(xi).Attachments.Count > 0 Then
            
                'Parcours des pièces jointes
                For xj = 1 To myItems.Item(xi).Attachments.Count
                
                    'myAttachments correspond aux PJ du message courant
                    Set myAttachments = myItems.Item(xi).Attachments
                
                    'Nom du message qui sera enregistré
                    nomFichier = "Message" & xi & "_" & xj & "_" & Date
                    
                    'On remplace les / par des _ pour pouvoir enregistrer les messages
                    nomFichier = Remplacement(nomFichier, "/", "_")
                    
                    'Sauvegarde de la ou les pièces jointes
                    myAttachments.Item(xj).SaveAsFile (chemin & "" _
                    & nomFichier & ".msg")
                
                Next
            
            End If
    
        Next xi
    
    End If

End If

'Fermeture du formulaire
Unload sauvegarde_PJ
 
End Sub

'Fonction qui remplace le CarARemplacer par CarRemplacement dans Texte
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

Télécharger le zip

23 mars 2005 13:56:01 :

j'ai mis mon projet en zip, comme on me l'a demandé, il comprend mon module et mon formulaire