Problème bon déroulement des étapes d'une macro

Bonjour à tous,

J'ai une macro sur laquelle je bosse qui me pose un soucis. Voici quelques détails des étapes:

1) Je dépose un mail dans un dossier Windows (Fonctionne nickel)

2) Je renomme le mail suivant différentes variables (Fonctionne nickel)

Et à partir de la j'ai deux fonctions qui suivent, une pour envoyer un mail à un client, une pour envoyer un mail en interne et ces deux fonctions dépendent du mail déposé et renommé sauf que:

- La première fonction utilise l'expéditeur et l'objet du mail déposé, avec une vérification de la présence du mail dans le dossier et j'ai du coup un msgbox qui me dit que je n'ai pas de mail alors qu'il a été correctement déposé.

- La seconde fonctionne, mais prend le mail du dossier pour le mettre en pièce jointe, cela se fait mais avant qu'il soit renommé.

J'ai l'impression que le programme n'a pas le temps de finir l'action renommer que les deux autre s'enchainent, ce qui du coup pose problème. J'ai essayé avec timer et toujours la même chose, et pour le DoEvent j'ai encore du mal à le maitriser.

Voici mon code (La première fonction est encore en travaux) si quelqu'un à une idée à me suggérer.

Shell Environ("WINDIR") & "\explorer.exe " & cheminDevis & "\0 - demande initiale", vbNormalFocus

MsgBox "Veuillez glisser le mail de demande de devis dans le dossier précédemment ouvert.", vbOKOnly, "Rangement de la demande de prix"

'Renommer le mail de demande de devis
Repertoire = cheminDevis & "\0 - demande initiale\"
nomMail = Dir(Repertoire & "*.msg")
If nomMail <> "" Then Name Repertoire & nomMail As Repertoire & "DT" & numDevis & " - Demande de devis.msg"

Call Envoyer_Mail_Client(cheminDevis)

tbl = EnumFichiers(cheminDevis & "\0 - demande initiale")

Envoyer_Mail_Deviseur tbl(), cheminDevis

Liste_DT.Activate

End Sub

Function Envoyer_Mail_Client(cheminDevis As String)

'Recherche des informations mail client + objet depuis le mail de demande de devis

'Déclaration des variables
Dim CheminMail, Fichier, Extension As String
Dim OlApp As Outlook.Application
Dim MailItem As Outlook.MailItem

'Nécessite d'activer la référence : Microsoft Outlook X.0 Object Library.
Set OlApp = CreateObject("Outlook.Application")
CheminMail = CheminDvs & "\0 - Demande initiale\"
Extension = "*.msg"
Fichier = Dir(CheminMail & Extension)

    If Fichier <> vbNullString Then

        Set MailItem = OlApp.Session.OpenSharedItem(CheminMail & Fichier)

            If MailItem.SenderEmailType = "SMTP" Then
                Worksheets("Feuil1").Cells(1, "A") = MailItem.SenderEmailAddress
            Else
                If MailItem.SenderEmailType = "EX" Then
                    Worksheets("Feuil1").Cells(1, "A") = MailItem.Sender.GetExchangeUser.PrimarySmtpAddress
                End If
            End If

            Worksheets("Feuil1").Cells(2, "A") = MailItem.Subject

    Else

        MsgBox "Pas de mail" 'A adapter selon besoin

    End If

Set Msg = Nothing
Set objOL = Nothing

End Function

Function Envoyer_Mail_Deviseur(tbl() As String, cheminDevis As String)
Dim ObjOutlook As New Outlook.Application
Dim oBjMail
Dim Nom_Fichier As String

    Set ObjOutlook = New Outlook.Application
    Set oBjMail = ObjOutlook.CreateItem(olMailItem)
    With oBjMail
        .To = mailDeviseur 'Destinataire
        '.CC = XXX 'Copie
        .Subject = "Devis Technique " & numDevis & " - " & Client 'Objet du mail
        .Body = "Bonjour," & vbCrLf & vbCrLf & "Ci-joint la demande de devis : DT" & numDevis & vbCrLf & vbCrLf & "Client : " & Client & vbCrLf & "Date de réponse cible : " & dateRepCible & vbCrLf & "Lien du dossier: file:\\" & Replace(cheminDevis, " ", "%20") & vbCrLf & vbCrLf & "Cordialement."
        For k = 1 To nbFichier
            Nom_Fichier = cheminDevis & "\0 - Demande initiale\" & tbl(k)
            .Attachments.Add Nom_Fichier
        Next k
        '.Attachments.Add Nom_Fichier '"C:\Data\essai.txt" ' ou Nomfichier
        .Display  'Ici on peut supprimer pour l'envoyer sans vérification
        '.Send
    End With
    'ObjOutlook.Quit
    Set oBjMail = Nothing
    Set ObjOutlook = Nothing

End Function

Bonjour Heelflip

Pour commencer, pensez à indenter votre code SVP, il est difficile à lire donné comme ça

Sinon, je pense simplement que vous ne donnez pas la bonne instruction à votre Dir()
De plus on ne créé pas une fonction, si on ne renvoie rien comme valeur et surtout on ne l'appelle pas avec un "Call"

Donc vous appelez votre Sub ainsi

  'Renommer le mail de demande de devis
  Repertoire = CheminDevis & "\0 - demande initiale\"
  nomMail = Dir(Repertoire & "*.msg")
  If nomMail <> "" Then Name Repertoire & nomMail As Repertoire & "DT" & NumDevis & " - Demande de devis.msg"
  Call Envoyer_Mail_Client(CheminDevis, NumDevis)

Ensuite, vous définissez votre Sub avec 2 arguments
Vous pouvez ainsi faire un Dir() avec le bon nom de fichier

'Recherche des informations mail client + objet depuis le mail de demande de devis
Sub Envoyer_Mail_Client(CheminDevis As String, NumDevis As String)
  'Déclaration des variables
  Dim CheminMail, Fichier, Extension As String
  'Nécessite d'activer la référence : Microsoft Outlook X.0 Object Library.
  Dim OlApp As Outlook.Application
  Dim MailItem As Outlook.MailItem
  '
  Set OlApp = CreateObject("Outlook.Application")
  CheminMail = CheminDvs & "\0 - Demande initiale\"
  Extension = "*.msg"
  Fichier = Dir(CheminMail & "*" & NumDevis & "*" & Extension)

Le plus simple serait même de mettre le nouveau du fichier dans une variable et l'envoyer à la Sub

A+

Bonjour Bruno,

Merci de ta réponse. Je suis désolé pour le code, je pensais l'avoir suffisamment indenté , mais c'est une partie que je ne maitrise pas encore, je vais repasser un peu de temps sur les cours.

J'ai un peu simplifié mon code depuis pour essayer de solutionner le problème et j'ai testé ton bout de code dessus mais pour l'instant chou blanc. Je te mets juste le code utile car la pièce jointe doit se trouver dans le mail deviseur et non dans le mail client. J'avoue que je ne savais pas trop au départ comment appeler les Sub/Fonctions mais il est vrai qu'appeler un Sub 2 à la fin d'un Sub 1 est une bonne idée surtout pour la compréhension du déroulement.

Après l'histoire Sub / Function reste encore un peu flou pour moi je pensais que les application nécessitaient des function mais apparemment non. Par contre je suis un peu perdu car dans ton bout de code tu Call Envoyer_Mail_Client alors que c'est un Sub, mais si je Call pas avec les deux ByRef ca ne fonctionne pas.

Du coup pour mon code, j'appelle mon sub Renommer_Mail_Création pour le renommer, cela fonctionne nickel et à la fin je lance le Sub Envoyer_Mail_Deviseur mais toujours la même chose j'ai le mail avec le nom d'origine donc avant qu'il soit renommé.

J'ai modifié ainsi:

'Reste du code non présent

Call CreationDossier(CheminDevis)

Shell Environ("WINDIR") & "\explorer.exe " & CheminDevis & "\0 - demande initiale", vbNormalFocus

MsgBox "Veuillez glisser le mail de demande de devis dans le dossier précédemment ouvert.", vbOKOnly, "Rangement de la demande de prix"

Renommer_Mail_Création (CheminDevis)

Liste_DT.Activate

End Sub

'--------------------------------------------------------------

Sub Renommer_Mail_Création(CheminDevis As String)

'Déclaration des variables
Dim Repertoire, Fichier, Extension As String

'Renommer le mail de demande de devis
Repertoire = CheminDevis & "\0 - demande initiale\"
Extension = "*.msg"
Fichier = Dir(Repertoire & Extension)
If Fichier <> "" Then Name Repertoire & Fichier As Repertoire & "DT" & numDevis & " - Demande de devis.msg"

Call Envoyer_Mail_Deviseur (CheminDevis, numDevis)

End Sub

'--------------------------------------------------------------

Private Sub Envoyer_Mail_Deviseur(CheminDevis As String, numDevis As Integer)

'Déclaration des variables
Dim NOlApp As New Outlook.Application
Dim Nom_Fichier As String

Set NOlApp = New Outlook.Application
Set MailItem = NOlApp.CreateItem(olMailItem)

With MailItem

    .Display
    .To = mailDeviseur 'Destinataire
    '.CC = XXX 'Copie
    .Subject = "Devis Technique " & numDevis & " - " & Client 'Objet du mail
    .Body = "Bonjour," & vbCrLf & vbCrLf & "Ci-joint la demande de devis : DT" & numDevis & vbCrLf & vbCrLf & "Client : " & Client & vbCrLf & "Date de réponse cible : " & dateRepCible & vbCrLf & "Lien du dossier: file:\\" & Replace(CheminDevis, " ", "%20") & vbCrLf & vbCrLf & "Cordialement."

    Repertoire = CheminDevis & "\0 - Demande initiale\"
    Extension = "*.msg"
    Fichier = Dir(Repertoire & "*" & numDevis & "*" & Extension)
    .Attachments.Add Repertoire & Fichier

Set NOlApp = Nothing
Set MailItem = Nothing

End With

End Sub

Re,

Ce que je ferais à ta place

Sub Renommer_Mail_Création(CheminDevis As String)
  'Déclaration des variables
  Dim Repertoire As STring, OldFic as String, NewFic as String, Ext As String
  'Renommer le mail de demande de devis
  Repertoire = CheminDevis & "\0 - demande initiale\"
  Extension = "*.msg"
  OldFic = Dir(Repertoire & Extension)
  If OldFic <> "" Then
    NewFic = "DT" & numDevis & " - Demande de devis.msg"
     Name Repertoire & OldFic As Repertoire & NewFic
     Call Envoyer_Mail_Deviseur (Repertoire, Newfic)
  End IF
End Sub

Ensuite

Private Sub Envoyer_Mail_Deviseur(Repertoire As String, NewFic as String)
  'Déclaration des variables
  Dim NOlApp As New Outlook.Application
  Dim Nom_Fichier As String
  Set NOlApp = New Outlook.Application
  Set MailItem = NOlApp.CreateItem(olMailItem)
  With MailItem
    .Display
    .To = mailDeviseur 'Destinataire
    '.CC = XXX 'Copie
    .Subject = "Devis Technique " & numDevis & " - " & Client 'Objet du mail
    .Body = "Bonjour," & vbCrLf & vbCrLf & "Ci-joint la demande de devis : DT" & numDevis & vbCrLf & vbCrLf & "Client : " & Client & vbCrLf & "Date de réponse cible : " & dateRepCible & vbCrLf & "Lien du dossier: file:\\" & Replace(CheminDevis, " ", "%20") & vbCrLf & vbCrLf & "Cordialement."
    .Attachments.Add Repertoire & NewFic
    Set NOlApp = Nothing
    Set MailItem = Nothing
  End With
End Sub

A voir

J'ai refait proprement les trois macros en gardant ta partie OldFichier/NewFichier et en virant les variables "mortes" mais toujours pareil, le mail garde le nom du OldFichier.

Private Sub Renommer_Mail_Création(CheminDevis As String)

'Déclaration des variables
Dim Repertoire As String
Dim OldFichier As String
Dim NewFichier As String
Dim Extension As String

'Renommer le mail de demande de devis
Repertoire = CheminDevis & "\0 - demande initiale\"
Extension = "*.msg"
OldFichier = Dir(Repertoire & Extension)
If OldFichier <> "" Then
    NewFichier = "DT" & numDevis & " - Demande de devis.msg"
    Name Repertoire & OldFichier As Repertoire & NewFichier

    Call Envoyer_Mail_Deviseur(Repertoire, NewFichier)
    Call Envoyer_Mail_Client(Repertoire, NewFichier)

End If

End Sub

'---------------------------------------------

Private Sub Envoyer_Mail_Client(Repertoire As String, NewFichier As String)

'Recherche des informations mail client + objet depuis le mail de demande de devis

'Déclaration des variables
Dim OlApp As Outlook.Application
Dim MailItem As Outlook.MailItem
Dim MailTo As String
Dim MailSubject As String

'Nécessite d'activer la référence : Microsoft Outlook X.0 Object Library.
Set OlApp = CreateObject("Outlook.Application")

    If Repertoire & NewFichier <> vbNullString Then

        Set MailItem = OlApp.Session.OpenSharedItem(Repertoire & NewFichier)

            If MailItem.SenderEmailType = "SMTP" Then
                MailTo = MailItem.SenderEmailAddress
            Else
                If MailItem.SenderEmailType = "EX" Then
                    MailTo = MailItem.Sender.GetExchangeUser.PrimarySmtpAddress
                End If
            End If

            MailSubject = "RE: " & MailItem.Subject

    Else

        MsgBox "Le dossier ne contient pas de mail.", vbExclamation, "Erreur - Envoyer_Mail_Client"

    End If

        'Envoi du mail

        'Déclaration des variables
        Dim NOlApp As New Outlook.Application

        Set NOlApp = New Outlook.Application
        Set MailItem = NOlApp.CreateItem(olMailItem)

        With MailItem

            .Display
            .To = MailTo 'Destinataire
            .CC = mailDeviseur 'Copie
            .Subject = MailSubject 'Objet du mail
            .HTMLBody = "<BODY style=font-size:11pt;font-family:Calibri>" & "Bonjour,<br>" _
                & " <br>" _
                & "Nous vous remercions BLA BLA BLA BLA BLA<br>" _
                & "We thank you BLA BLA BLA BLA BLA<br>" _
                & " <br>" _
                & "Cordialement" & "</BODY>" & .HTMLBody
            '.Send
        End With

'ObjOutlook.Quit
Set OlApp = Nothing
Set NOlApp = Nothing
Set MailItem = Nothing

End Sub

'---------------------------------------------

Private Sub Envoyer_Mail_Deviseur(Repertoire As String, NewFichier As String)

'Déclaration des variables
Dim NOlApp As New Outlook.Application
Dim Nom_Fichier As String

Set NOlApp = New Outlook.Application
Set MailItem = NOlApp.CreateItem(olMailItem)

With MailItem

    .Display
    .To = mailDeviseur 'Destinataire
    '.CC = XXX 'Copie
    .Subject = "Devis Technique " & numDevis & " - " & Client 'Objet du mail
    .Body = "Bonjour," & vbCrLf & vbCrLf & "Ci-joint la demande de devis : DT" & numDevis & vbCrLf & vbCrLf & "Client : " & Client & vbCrLf & "Date de réponse cible : " & dateRepCible & vbCrLf & "Lien du dossier: file:\\" & Replace(CheminDevis, " ", "%20") & vbCrLf & vbCrLf & "Cordialement."
    .Attachments.Add Repertoire & NewFichier

Set NOlApp = Nothing
Set MailItem = Nothing

End With

End Sub

Je sèche carrément sur le pourquoi, la fonction me parait vraiment logique en relisant.

Re,

Dans ces conditions il faudra nous joindre le fichier, ou sinon, je ne pourrais pas vous aider plus

A+

Bruno,

Je fais faire un fichier modifié qui fonctionne car la tout est via des liens vers le serveur du boulot. Ensuite je le partagerai

Bonjour Bruno,

Voici le fichier Excel.

La macro est sur le bouton dans l'onglet 1. Pour le faire fonctionner correctement, il faut te créer un dossier sur ton bureau et de mettre le chemin vers le dossier dans l'onglet Données, Ligne 15, j'ai mis la ligne en Jaune. C'est dans ce dossier que la Macro va opérer et que tu y déposeras la mail à renommer.

Ensuite il suffit de remplir dans le UserForm Chargé d'affaire, Client et Catégorie et ça suffit pour Valider. J'ai cherché tout le weekend une solution mais rien n'y fait...

Salut Clément

C'est un truc de dingue, quelque chose m'échappe

J'ai beau avoir modifié un tas de choses, c'est toujours le fichier mis à l'origine qui est envoyé et pourtant

Voici toujours le fichier avec les modifications

A+

Bruno,

Mais tellement je n’arrive pas à comprendre pourquoi non plus... Ça me rend fou

J'espère que quelqu'un qui passera par là aura une explication...

Merci pour ton aide en tout cas, je continue à chercher.

Bruno,

J'ai trouvé... C'est tellement nul... Au final nos codes respectifs fonctionnent bien, mais fait le test d'envoyer en manuel un mail renommé, il arrive en pièce jointe avec son nom de départ et pas le nom que tu lui as attribué, voilà pourquoi cela ne fonctionne pas en macro, car ça ne fonctionne pas plus en manuel...

C'est donc résolu, pas de solution, mais une réponse qui permet de se dire qu'on est pas fous