VBA Macro Outlook : Exporter résultats de sondages mails (par boutons de vote) sur Excel

vn9596

XLDnaute Nouveau
Bonjour
Novice sur VBA, je me prends à me passionner pour ce monde plein de potentiel, et ce sujet est mon premier que je poste moi-même (habituellement je trouve toutes mes solutions sur la toile, grâce aux forums comme ici, et merci à vous tous au passage).

Contexte:
Je travaille sur Microsoft 365.
Je souhaite mettre en place au moins 2 dispositifs dont le deuxième me paraît le plus dur (et important):

1/ Un mail automatiquement généré destiné à une liste d'adresses avec inclusion d'un bouton de vote ("Valider"/"Refuser" par ex).
Cette liste d'adresses serait référencée dans un classeur Excel et je pensais notamment à du publipostage, mais ne pouvant pas inclure un bouton de vote automatiquement avec le publipostage, je réfléchis à une macro.
J'ai une grossière macro pour la génération de ce mail :

Code:
Sub envoie_mail()
Dim olApp As Outlook.Application
Dim OLspace As Outlook.Namespace
Dim OLinbox As Outlook.MAPIFolder
Dim OLfolder As Outlook.MAPIFolder
Dim OLmail As Outlook.MailItem
Dim OLpj As Outlook.Attachment
Dim Msg As MailItem
Set objOL = New Outlook.Application
Set Msg = objOL.CreateItem(olMailItem)
Msg.To = Email
Msg.Subject = Range("Mail_subject")
Msg.Body = "Hello," & vbNewLine & vbNewLine & _
"Please be informed that Blablabla" & vbNewLine & vbNewLine & _
'Msg.Attachments.Add Source:=nom_doc
Msg.VotingOptions = "Valider;refuser"
Msg.To = Email
Msg.Display
Set objOL = Nothing
End Sub

2/ Je déterre ce sujet de 2009 qui correspond à ce que je cherche, et qui m'a fait avancer, me semble-t-il.
Je souhaite faire une exportation automatique sur Excel des résultats de vote par mail évoqué ci-avant, et les voir s'afficher et compilés tout propres sur une feuille de calcul, (dans le but de faire des relances automatiques dans un 3ème temps pour ceux qui n'ont pas voté...).

J'ai donc cette macro, qui me sort une "Erreur d'exécution '13' : incompatibilité de type" en me surlignant le "Next" en jaune...

Code:
Sub chMail()
Set olApp = CreateObject("Outlook.application")
Set OLspace = olApp.GetNamespace("MAPI")
Set OLinbox = OLspace.GetDefaultFolder(olFolderInbox)
Dim OLmail As Outlook.MailItem
For Each OLmail In OLinbox.Items
    If OLmail.Subject = "Valider: " Then
    Dim OLbody As String
    OLbody = OLmail.SenderName
    olresponse = OLmail.VotingResponse
    oltime = OLmail.CreationTime
    olrecus = OLmail.ReceivedTime
    olreceipt = OLmail.ReadReceiptRequested
    Sheets(1).Range("A" & i).Select
    With Selection
    .Value = OLbody
    End With
    Sheets(1).Range("B" & i).Select
    With Selection
    .Value = olresponse
    End With
    Sheets(1).Range("C" & i).Select
    With Selection
    .Value = oltime
    End With
    Sheets(1).Range("D" & i).Select
    With Selection
    .Value = olrecus
    End With
    Sheets(1).Range("E" & i).Select
    With Selection
    .Value = olreceipt
    End With
    ElseIf OLmail.Subject = "Refuser: " Then
    OLbody = OLmail.SenderName
    olresponse = OLmail.VotingResponse
    oltime = OLmail.CreationTime
    olrecus = OLmail.ReceivedTime
    Sheets(1).Range("A" & i).Select
    With Selection
    .Value = OLbody
    End With
    Sheets(1).Range("B" & i).Select
    With Selection
    .Value = olresponse
    End With
    Sheets(1).Range("C" & i).Select
    With Selection
    .Value = oltime
    End With
    Sheets(1).Range("D" & i).Select
    With Selection
    .Value = olrecus
    End With
    Sheets(1).Range("E" & i).Select
    End If
    i = i + 1
Next
End Sub

(Dans un dernier temps, je ne suis pas contre des idées pour organiser les relances de mails si pas de réponses après x jours)

Je précise que je ne comprends évidemment pas tout tout tout des subtilités des lignes de code que je vous écris ici.
Je suis à l'écoute de toute piste intéressante :)
Merci par avance
 
Dernière édition:

fanch55

XLDnaute Barbatruc
Salut,
Je vous conseille de créer un Dossier dans outlook et de faire un filtre dans celui-ci pour déplacer automatiquement les réponses reçues.

Correction de la macro de Réception :
VB:
Sub chMail2()
Dim Ligne()
Dim olMail As Outlook.MailItem

Set olApp = CreateObject("Outlook.application")
Set olRoot = olApp.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Parent
Set olInbox = olRoot.Folders("Archive").Folders("$Vote")
Set F = Sheets("Feuil1")

    F.Cells.Clear
    I = 1
    Ligne = Array("Objet", "Emetteur", "Timbre", "Réponse")
    F.Range("A" & I).Resize(, UBound(Ligne) + 1) = Ligne
    F.ListObjects.Add(xlSrcRange, F.Range("A1").Resize(, UBound(Ligne) + 1), , xlYes).Name = "Réponses"
    F.ListObjects("Réponses").TableStyle = "TableStyleMedium6"
   
    For Each olMail In olInbox.Items
        With olMail
            If .Subject Like "Valider:*" Or .Subject Like "Refuser:*" Then
                I = I + 1
                Ligne = Array(.Subject, .SenderName, .ReceivedTime, .VotingResponse)
                F.Range("A" & I).Resize(, UBound(Ligne) + 1) = Ligne
            End If
        End With
    Next
    F.Columns.AutoFit
   
Set F = Nothing
   
Set olInbox = Nothing
Set olRoot = Nothing
Set olApp = Nothing
   
End Sub

Pour indiquer le dossier où sont déposées les réponses :
Set olInbox = olRoot.Folders("Archive").Folders("$Vote")
 
Dernière édition:

vn9596

XLDnaute Nouveau
Merci beaucoup,
En effet ce programme semble bcp m'aider pour ce que je recherche. Je vais prendre le temps de me l'approprier, mais déjà ça a l'air sympathique (jamais je n'aurais fait ca seul). Je ne parviens pas à mettre dans ce tableau formé l'adresse mail de l'expéditeur, lorsque je mets la variable (je ne sais pas si le terme est le bon) ".senderEmailAdress", une suite de caractère s'affiche avec le prénom nom à la fin (Ex : /O=EXCHANGELABS/OU=EXCHANGE ADMINISTRATIVE GROUP (FYDIBOHF23SPDLT)/CN=RECIPIENTS/CN=5F1E0069F56F4C5898B91B092233EC70-PRENOM NOM), mais je n'ai pas l'adresse mail, qui me serait utile pour mon programme, afin de pouvoir faire le rapprochement avec une liste de base dont l'ID est le mail.
 
Dernière édition:

fanch55

XLDnaute Barbatruc
Bonsoir,

le .sendername devrait pouvoir vous suffire car le .senderEmailAddress est trop riche, il correspond à toute une trame de cheminement identifiant le serveur émetteur utilisé par l'utilisateur répondeur:
 

vn9596

XLDnaute Nouveau
Le .SenderName me donne le nom de l'expéditeur (comme le .Sender), vous l'avez d'ailleurs utilisé vous-même ; mais je n'ai pas l'adresse mail avec le @xxx.com.
Je suis quand même un peu soufflé par le niveau que vous semblez avoir, et le caractère complet et compact de ce que vous m'avez proposé.
 

fanch55

XLDnaute Barbatruc
Peut-être ne parlons nous pas de la même chose .
Voici ce que j'ai dans mes tests :
1595548089435.png

Résultats produits avec le code ci-joint :
VB:
Sub chMail2()
Dim Ligne()
Dim olMail As Outlook.MailItem

Set olApp = CreateObject("Outlook.application")
Set olRoot = olApp.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Parent
Set olInbox = olRoot.Folders("Archive").Folders("$Vote")
Set F = Sheets("Feuil1")

    F.Cells.Clear
    I = 1
    Ligne = Array("ConversationId", "Subject", "ReceivedTime", "VotingResponse", _
             "Sendername", "Sender", "SenderEmailType", "SenderEmailAddress", "ReceivedByName")
    F.Range("A" & I).Resize(, UBound(Ligne) + 1) = Ligne
    F.ListObjects.Add(xlSrcRange, F.Range("A1").Resize(, UBound(Ligne) + 1), , xlYes).Name = "Réponses"
    F.ListObjects("Réponses").TableStyle = "TableStyleMedium6"
  
    For Each olMail In olInbox.Items
        With olMail
            If .Subject Like "Valider:*" Or .Subject Like "Refuser:*" Then
                I = I + 1
                Ligne = Array(.ConversationID, .Subject, .ReceivedTime, .VotingResponse, _
                    .SenderName, .Sender, .SenderEmailType, .SenderEmailAddress, .ReceivedByName)
                F.Range("A" & I).Resize(, UBound(Ligne) + 1) = Ligne
            End If
        End With
    Next
    F.Columns.AutoFit
  
Set F = Nothing
  
Set olInbox = Nothing
Set olRoot = Nothing
Set olApp = Nothing
  
End Sub

Qu'avez-vous dans .SenderEmailType ?
 

vn9596

XLDnaute Nouveau
Cf ci-joint mon rendu de test avec ce dernier code (que j'ai adapté avec mes votes ("read and understood" en l'occurrence) et mes dossiers d'intérêt, mais que j'ai rendu anonyme évidemment). Victor XXX étant moi-même par ex.
Comme vous pouvez le voir, les adresses email n'apparaissent nulle part
1595578374867.png
 

fanch55

XLDnaute Barbatruc
Oki, votre serveur est un serveur interne à l'entreprise;
Pourriez-vous utiliser le code ci-dessous ( je ne peux pas le vérifier par moi-même )
VB:
Sub chMail2()
Dim Ligne()
Dim olMail As Outlook.MailItem

Set olApp = CreateObject("Outlook.application")
Set olRoot = olApp.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Parent
Set olInbox = olRoot.Folders("Archive").Folders("$Vote")
Set F = Sheets("Feuil1")

    F.Cells.Clear
    I = 1
    Ligne = Array("ConversationId", "Subject", "ReceivedTime", "VotingResponse", _
             "Sendername", "Sender", "SenderEmailType", "SenderEmailAddress", "ReceivedByName")
    F.Range("A" & I).Resize(, UBound(Ligne) + 1) = Ligne
    F.ListObjects.Add(xlSrcRange, F.Range("A1").Resize(, UBound(Ligne) + 1), , xlYes).Name = "Réponses"
    F.ListObjects("Réponses").TableStyle = "TableStyleMedium6"
  
    For Each olMail In olInbox.Items
        With olMail
            If .Subject Like "Valider:*" Or .Subject Like "Refuser:*" Then
                I = I + 1
                If .SenderEmailType = "EX" Then
                    SmAdress = .Sender.GetExchangeUser.PrimarySmtpAddress
                Else
                    SmAdress = .SenderEmailAddress
                End If
                Ligne = Array(.ConversationID, .Subject, .ReceivedTime, .VotingResponse, _
                    .SenderName, .Sender, .SenderEmailType, SmAdress, .ReceivedByName)
                F.Range("A" & I).Resize(, UBound(Ligne) + 1) = Ligne
            End If
        End With
    Next
    F.Columns.AutoFit
  
Set F = Nothing
  
Set olInbox = Nothing
Set olRoot = Nothing
Set olApp = Nothing
  
End Sub

Si une erreur se produit, faites une capture d'écran sinon dites moi ce qu'il y a dans la colonne SenderEmailAddress :rolleyes:
 

vn9596

XLDnaute Nouveau
Bravo, en effet dans SenderEmailAddress se trouvent les adresse en effet… Vous êtes très fort merci. De mon côté dans mon ptit apprentissage j'ai passé l'après-midi à faire avancer ce (pour moi) gros projet, d'autres petits problèmes se dessinent et c'est passionnant de faire sauter ces verrous un à un. Je ne manquerait pas de publier le rendu global si ici un jour qq1 voudrait s'y référer.
 

vn9596

XLDnaute Nouveau
Bonjour
Ayant bénéfié de l'expérience et la gentillesse de franch55, je me dois de publier ici le rendu final.

J'ai donc à présent une fonctionnalité qui semble marcher, ayant bien entendu adapté les instructions trouvées ici :
Contexte : "Pro_Name_VX_X_Ref" est le nom donné à ma cellule de choix de référence, une cellule contenant une liste déroulante, avec pour source de celle-ci un tableau (dans un onglet"Liste 000") de l'ensemble des procédures sur lesquelles je souhaite travailler.

VB:
Function FeuilleExiste(wk As Workbook, stFeuille) As Boolean
On Error Resume Next
FeuilleExiste = Not (wk.Sheets(stFeuille) Is Nothing)
End Function

Sub Votes_import()
Dim Ligne()
Dim olMail As Outlook.MailItem

Set olApp = CreateObject("Outlook.application")
Set olRoot = olApp.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Parent
MsgBox (" Attention, le fichier dans le classeur Publications de Outlook doit avoir exactement le même nom que le doc dans le tableau Liste 000 ! ")
Set OLinbox = olRoot.Folders("Publications").Folders(Range("Pro_Name_VX_X_Ref").Value)

    Application.DisplayAlerts = False
    If FeuilleExiste(ThisWorkbook, Range("Pro_Name_VX_X_Ref").Value) Then
    Sheets(Range("Pro_Name_VX_X_Ref").Value).Delete
    End If
    Worksheets.Add After:=ActiveSheet
    ActiveSheet.Name = Range("Pro_Name_VX_X_Ref").Value
    Application.DisplayAlerts = True



    Sheets(Range("Pro_Name_VX_X_Ref").Value).Cells.Clear
    i = 1
    Ligne = Array("SenderName", "SenderEmailAdress", "ReceivedTime", "VotingResponse")
    Sheets(Range("Pro_Name_VX_X_Ref").Value).Range("F" & i).Resize(, UBound(Ligne) + 1) = Ligne
    Sheets(Range("Pro_Name_VX_X_Ref").Value).ListObjects.Add(xlSrcRange, Sheets(Range("Pro_Name_VX_X_Ref").Value).Range("F1").Resize(, UBound(Ligne) + 1), , xlYes).Name = "Réponses"
    Sheets(Range("Pro_Name_VX_X_Ref").Value).ListObjects("Réponses").TableStyle = "TableStyleMedium2"

    For Each olMail In OLinbox.Items
        With olMail
            If .Subject Like "Read and understood*" Or .Subject Like "Additional info needed*" Then
               
                i = i + 1
                If .SenderEmailType = "EX" Then
                    SmAdress = .Sender.GetExchangeUser.PrimarySmtpAddress
                Else
                    SmAdress = .SenderEmailAddress
                End If
                Ligne = Array(.SenderName, SmAdress, .ReceivedTime, .VotingResponse)
                Sheets(Range("Pro_Name_VX_X_Ref").Value).Range("F" & i).Resize(, UBound(Ligne) + 1) = Ligne
            End If
        End With
    Next
 
Set OLinbox = Nothing
Set olRoot = Nothing
Set olApp = Nothing

Sheets(Range("Pro_Name_VX_X_Ref").Value).Activate
Range("Réponses").Sort Key1:=Range("F1"), Header:=xlYes
Sheets(Range("Pro_Name_VX_X_Ref").Value).Columns.AutoFit
End Sub
 

Discussions similaires

Réponses
4
Affichages
450

Statistiques des forums

Discussions
315 094
Messages
2 116 150
Membres
112 670
dernier inscrit
Flow87