VBA - récupération info. email

Bonjour,

J'ai un dossier contenant plusieurs emails au format *.msg (ce n'est pas un dossier dans Outlook mais sur mon bureau).
Après quelques recherches, j'ai pu faire une macro qui passe les fichiers en revue et récupère quelques informations.

Lorsque je l'exécute, j'ai une erreur d'exécution "2147287038 (80030002)" m'indiquant que le fichier est soit ouvert, soit que je n'ai pas les autorisations pour l'ouvrir.
L'erreur intervient sur la ligne "Set OutApp = CreateObject("Outlook.Application")".
J'ai testé ça sur mon PC sur lequel j'ai bien tous les droits.
Avez-vous une idée pour solutionner cette erreur ?

Le code :

Sub Bouton1_Cliquer()

Dim OutApp As Object
Dim Message As Object
Dim DossierCourant As String
Dim Liste As String
Dim Fichier As String
Dim i As Integer

Set OutApp = CreateObject("Outlook.Application")

DossierCourant = ThisWorkbook.Path
Liste = DossierCourant & "\*.msg"
i = 3
Fichier = Dir(Liste)

Set Message = OutApp.CreateItemFromTemplate(Fichier)

Do While Fichier <> ""
    Cells(i, 2).Value = DossierCourant
    Cells(i, 3).Value = Message.Subject
    Cells(i, 4).Value = Message.ReceivedTime
    Cells(i, 5).Value = Message.SenderEmailAddress
    OutApp.Quit
    Set OutApp = Nothing
    Set Message = Nothing

    Fichier = Dir
    Set Message = OutApp.CreateItemFromTemplate(Fichier)
Loop

End Sub

Merci

Bonjour,

Je ne connais pas bien Outlook mais avez-vous activé la référence Outlook ?

Depuis l'éditeur VBA, Menu Outils/Références/Microsoft Outlook Library XX.0 ...

Cdlt,

Oui, j'ai oublié de préciser mais la librairie est bien activée dans l'éditeur VBA.

Bonjour,

Alors, je n'ai pas vraiment d'idée, désolé...

J'ai vu ce lien : http://excel.ipgirl.com/ouvrez-le-file-outlook-msg-en-utilisant-vba-partir-dexcel.html

qui laisse penser qu'il s'agit d'un problème d'autorisation.

Cdlt,

C'est effectivement ce que ça indique.
J'avais réalisé un test simplifié qui avait marché, ce qui exclut ce problème d'autorisation.
Dans le test simplifié j'avais renseigné le chemin complet du fichier en dur.

Avec un MsgBox(Fichier) Je me rends compte que la macro ne voit que le nom du fichier et non l'adresse complète ce qui la perturbe.
J'ai donc revu les définitions de la variable "Fichier" en incluant "DossierCourant & "\" &".

La première itération fonctionne correctement mais j'ai eu une "erreur d'exécution '91'" (variable objet de bloc With non définie) qui intervient au moment sur le "Set Message ..." de la boucle.
Ça semble lié au OutApp qui ne serait pas définit dans la boucle. Pour résoudre ça, j'y ai ajouté un "Set OutApp ..." et ça fonctionne.
Dernier point un peu curieux que je n'ai pas encore solutionné : la boucle fait une itération de plus que le nombre de fichiers.
Elle essaie donc d'ouvrir 'rien' (le dernier nom de la variable Fichier est égal à DossierCourant\ sans fichier) et je me retrouve avec une erreur du même type que la première fois.
C'est un moindre mal puisque j'arrive à générer mon tableau jusqu'au bout.

Sub Bouton1_Cliquer()

Dim OutApp As Object
Dim Message As Object
Dim DossierCourant As String
Dim Liste As String
Dim Fichier As String
Dim i As Integer

Set OutApp = CreateObject("Outlook.Application")

DossierCourant = ThisWorkbook.Path
Liste = DossierCourant & "\*.msg"
i = 3
Fichier = DossierCourant & "\" & Dir(Liste)

Set Message = OutApp.CreateItemFromTemplate(Fichier)

Do While Fichier <> ""
    Cells(i, 2).Value = DossierCourant
    Cells(i, 3).Value = Message.Subject
    Cells(i, 4).Value = Message.ReceivedTime
    Cells(i, 5).Value = Message.SenderEmailAddress
    OutApp.Quit
    Set OutApp = Nothing
    Set Message = Nothing
    i = i + 1

    Fichier = DossierCourant & "\" & Dir
    Set OutApp = CreateObject("Outlook.Application")
    Set Message = OutApp.CreateItemFromTemplate(Fichier)
Loop

End Sub

Bonjour Oups,

Tant mieux, le problème est quasiment résolu alors !

Pouvez-vous essayer avec ce code pour ce souci de dernier message :

Sub Bouton1_Cliquer()

Dim OutApp As Object
Dim Message As Object
Dim Dossier As String
Dim Liste As String
Dim Fichier As String
Dim i As Integer

Set OutApp = CreateObject("Outlook.Application")
i = 3
Dossier = ThisWorkbook.Path & "\"
Fichier = dir(Dossier & "*.msg")

Do While Fichier <> ""
    Set Message = OutApp.CreateItemFromTemplate(Dossier & Fichier)
    Cells(i, 2).Value = DossierCourant
    Cells(i, 3).Value = Message.Subject
    Cells(i, 4).Value = Message.ReceivedTime
    Cells(i, 5).Value = Message.SenderEmailAddress
    i = i + 1
    Fichier = Dir
Loop

OutApp.Quit
Set Message = Nothing
Set OutApp = Nothing

End Sub

Cdlt,

Bonjour,

Merci pour la proposition.
Ce code fonctionne correctement.
Je suppose que c'est lié au premier "Set Message ..." qui est fait dans la boucle.

J'avais lu qu'il fallait intégrer le code suivant entre les mails mais vu votre code ce n'est pas nécessaire.

Set Message = Nothing
Set OutApp = Nothing

Bonjour Oups,

Oui, c'était lié à un mauvais enchainement des instructions.

Comme je vous ai dit, je ne suis pas super calé sur Outlook mais j'ai supposé que le fait de laisser l'application ouverte ne gênerait pas, au contraire (ça évite de quitter, libérer, réinstancier).

Si ça n'avait pas marché, j'aurais replacé les lignes dans la boucle mais en veillant à réinstancier Outlook.

Cdlt,

Je suis d'accord, c'est plus logique et normalement plus rapide (même si dans mon cas je ne vois pas la différence).