Fermeture automatique boîte mail outlook en fonction de l'utilisateur

Bonjour à tous,

Je vous contacte car je n'arrive pas à écrire la fin de ma macro.

J'ai créé une macro qui envoi par mail un lien pour accéder à un document. Cependant certaines boîtes mails sont accessibles à plusieurs personnes et pourraient engendrer des erreurs. Afin de les éviter, je souhaite pour ce compte fermer automatiquement la boîte mail après un délai suite à l'envoi du mail.

Pourriez-vous m'aider à finaliser ma macro pour quelle fasse les actions suivantes :

- Fermeture de la boîte mail après un délai d'une minute si l'utilisateur est : Patrick ou Pierre

- Autres utilisateurs, la boîte mail reste ouverte.

Sinon, autre question, j'ai utilisé un code qui permet de vérifier si la boîte mail est ouverte sinon elle est ouverte, pensez-vous qu'il est possible de revenir à l'état initial plutôt que de fermer la boîte mail d'un seul ou de quelques utilisateurs ? A savoir si avant l'envoi de mail, la boîte mail outlook était ouverte, alors elle reste ouverte après l'envoi du mail et se elle était fermée, la boîte mail se referme ?

Merci d'avance pour votre aide.

Bonjour Tik et Tok,

Il serait bien de donner votre code actuel anonymisé SVP

@+

Bonjour BrunoM45,

ci-dessous le code qui me permet de vérifier si la boîte mail est ouverte et sinon de l'ouvrir :

'ouverture boite mail si non ouverte

#Const LateBind = True

Const olMinimized As Long = 1
Const olMaximized As Long = 2
Const olFolderInbox As Long = 6

#If LateBind Then

Public Function OutlookApp( _
    Optional WindowState As Long = olMinimized, _
    Optional ReleaseIt As Boolean = False _
    ) As Object
    Static o As Object
#Else
Public Function OutlookApp( _
    Optional WindowState As Outlook.OlWindowState = olMinimized, _
    Optional ReleaseIt As Boolean _
) As Outlook.Application
    Static o As Outlook.Application
#End If
On Error GoTo ErrHandler

    Select Case True
        Case o Is Nothing, Len(o.Name) = 0
            Set o = GetObject(, "Outlook.Application")
            If o.Explorers.Count = 0 Then
InitOutlook:
                'Open inbox to prevent errors with security prompts
                o.Session.GetDefaultFolder(olFolderInbox).Display
                o.ActiveExplorer.WindowState = WindowState
            End If
        Case ReleaseIt
            Set o = Nothing
    End Select
    Set OutlookApp = o

ExitProc:
    Exit Function
ErrHandler:
    Select Case Err.Number
        Case -2147352567
            'User cancelled setup, silently exit
            Set o = Nothing
        Case 429, 462
            Set o = GetOutlookApp()
            If o Is Nothing Then
                Err.Raise 429, "OutlookApp", "Outlook Application does not appear to be installed."
            Else
                Resume InitOutlook
            End If
        Case Else
            MsgBox "Error " & Err.Number & ": " & Err.Description, vbCritical, "Unexpected error"
    End Select
    Resume ExitProc
    Resume
End Function

#If LateBind Then
Private Function GetOutlookApp() As Object
#Else
Private Function GetOutlookApp() As Outlook.Application
#End If
On Error GoTo ErrHandler

    Set GetOutlookApp = CreateObject("Outlook.Application")

ExitProc:
    Exit Function
ErrHandler:
    Select Case Err.Number
        Case Else
            'Do not raise any errors
            Set GetOutlookApp = Nothing
    End Select
    Resume ExitProc
    Resume
End Function

Sub MyMacroThatUseOutlook()
    Dim OutApp  As Object
    Set OutApp = OutlookApp()
    'Automate OutApp as desired
End Sub

Et ensuite la partie concernant l'envoi de mail :

'Déclaration des variables nécessaires à l'envoi du mail
Dim ObjOut As Object
Dim LeMail As Object
Const olMailItem As Long = 0

Dim FirstRow As Long, LastRow As Long, Lig As Long
Dim LstObj As ListObject
Dim MaCol As New Collection
Dim Service As String, Service2 As String
Dim Dest As String  ' Liste du/des destinataire
Dim strbody As String

'**********Préparation du destinataire ************
 ' Récupérer les noms des services émetteurs et concernés dans le formulaire
  Service = ThisWorkbook.Sheets("Formulaire").Range("H15") 'Service 1
  Service2 = ThisWorkbook.Sheets("Formulaire").Range("H21") 'Service 2

'Définir le tableau des emails
  Set LstObj = ThisWorkbook.Sheets("Listes").ListObjects("AdressesMail")

' Première ligne et dernière ligne du tableau avec les adresses mail
  FirstRow = LstObj.HeaderRowRange.Row + 1
  LastRow = LstObj.DataBodyRange.Rows.Count
  Dest = ""

 'Pour chaque ligne du tableau mail
 For Lig = FirstRow To LastRow

   ' Vérifier si le service du formulaire correspond à ceux du tableau mail
   If LstObj.DataBodyRange.Cells(Lig, 1) = Service Or LstObj.DataBodyRange.Cells(Lig, 1) = Service2 Then

    ' N'ajouter que si l'email est différent
      On Error Resume Next
      MaCol.Add Lig, LstObj.DataBodyRange.Cells(Lig, 2)
      If Err.Number = 0 Then
        Dest = Dest & LstObj.DataBodyRange.Cells(Lig, 2) & "; "
      End If
      On Error GoTo 0
    End If
  Next Lig

'******* Partie Mail**********

    ' Créer une instance outlook
  Set ObjOut = CreateObject("outlook.application")
  Set LeMail = ObjOut.CreateItem(olMailItem)

  'Corps du mail
   strbody = "Bonjour, Un nouveau formulaire a été émis.<br><br> Bonne journée" 'Corps du mail

  ' Avec le nouveau mail
  With LeMail
    .Subject = "Nouveau formulaire" 'Sujet du mail
            .To = Dest 'Destinataire du mail
            .Sender = ""
            .HTMLBody = strbody & .HTMLBody
           .Send 'envoi du mail
   End With

' Effacer les variables objet
  Set LeMail = Nothing: Set LstObj = Nothing

Ce qu'il me manque c'est la fermeture des boîtes mails quand elles sont accessibles par plusieurs personnes.

Merci d'avance pour votre aide.