Autres Envoi mail automatique (suivant numéro de la semaine)

Nikoko

XLDnaute Nouveau
Bonjour,

J'ai déjà trouvé mon bonheur sur le forum concernant la première partie de ma problématique: Envoyer un mail automatique (à 2 semaines) de relance en fonction d'une date.

Cependant pour finaliser mon tableau, je n'arrive pas à envoyer le mail en fonction d'un numéro de semaine à la place d'une date (JJ-MM-AA).

Pouvez-vous m'aider?

Nota : Même avec une méthode détournée, c'est-à-dire que je complète manuellement numéro (format nombre) en colonne B, et la macro se réfère au numéro de semaine (format nombre) de référence que j'inscris en colonne J.

VB:
Sub Email()

Dim outlookDossier As Outlook.MAPIFolder
Dim outlookMessage As Outlook.MailItem
Dim VAdresse As String
Dim VObjet As String
Dim VMessage As String
Dim VCellule As Object
Dim Lig As Long
Dim DateRef

DateRef = DateAdd("ww", 2, Date)  ' date semaine +2

Lig = 2
Do While Cells(Lig, 1).Value <> ""
  If Cells(Lig, 6).Value = "" Then
       VMessage = ""
       ClientEnCours = Cells(Lig, 1).Value
       VAdresse = Cells(Lig, 5).Value ' adresse du destinataire
       While ClientEnCours = Cells(Lig, 1).Value  ' On traite les lignes du client
         If Cells(Lig, 2).Value < DateRef Then    ' date < date de référence
            Cells(Lig, 6).Value = "Envoyé"
            VMessage = VMessage & " votre facture n° " & Cells(Lig, 4).Value _
                   & " à échéance " & Format(Cells(Lig, 2).Value, "DD/MM/YYYY") _
                   & " merci de nous faire un retour avant le " & Cells(Lig, 7).Value _
                   & " pour un montant de " & Format(Cells(Lig, 3).Value, "# ##0.00 €") _
                   & " est impayée, " & vbCrLf
            VObjet = VObjet & " votre facture n° " & Cells(Lig, 4).Value _
                   & " est impayée, " & vbCrLf1
          End If
          Lig = Lig + 1
       Wend
       If VMessage <> "" Then  'envoyer message si existe
          VMessage = "Bonjour," & vbCrLf & vbCrLf & VMessage
          VMessage = VMessage & vbCrLf & "Cordialement" 'description
          VObjet = " Relance echeance " & vbCrLf1 & VObjet 'object

          Set outlookDossier = GetObject("", "Outlook.Application").GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
          Set outlookMessage = outlookDossier.Items.Add
          With outlookMessage
           .Subject = VObjet
           .Recipients.Add VAdresse
           .Body = VMessage
           .OriginatorDeliveryReportRequested = True
           .ReadReceiptRequested = True
           .Display
          End With
        End If

   Else
       Lig = Lig + 1
   End If
Loop

Set outlookMessage = Nothing
Set outlookDossier = Nothing

End Sub

J'espère avoir été clair.

Merci par avance de l'aide que vous pourriez m'apporter.
 

Pièces jointes

  • Email - Copie.xls
    62.5 KB · Affichages: 40
Dernière édition:

Discussions similaires

Réponses
1
Affichages
119
Réponses
6
Affichages
268
Réponses
0
Affichages
83

Statistiques des forums

Discussions
311 720
Messages
2 081 896
Membres
101 833
dernier inscrit
sandra25