L'utilisatuer se positionne dans le dossier qui veut (boite de reception, d'envoi, elements envoyés, ...) puis active la macro qui ouvre un formulaire qui lui demande le chemin où il veut que les pièces jointes soient enregistrées. La macro enregistre les pieces jointes de tous les messages du dossier dans le repertoire donné avec comme nom Message + numéro du message + numéro de la piece jointe + date du jour.
ActionFrm est une variable qui se met à vbOk quand l'utilisateur clique sur OK dans le formulaire, ou à vbCancel s'il clique sur Cancel
Source / Exemple :
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
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.