Envoyer un Mail quand la couleur de la case change VDA

Le 08/02/2023 à 11:35

Salut à tous,

Actuellement j'ai un tableau avec des chiffres et des couleurs

Quand le chiffre est trop bas la case change toute seul de couleur (j'ai 148 ligne et 3colonnes) mon soucis est le suivant :

Je veux que quand ma case soit rouge un mail soit envoyé pour cela j'ai trouvé ce code (sur extend office "How to send email if due date has been met in Excel?" ) mais il envoie un mail en fonction d'une date dans une case donc pas vraiment ce que je recherche.

Public Sub CheckAndSendMail()
'Updated by Extendoffice 2018/11/22
    Dim xRgDate As Range
    Dim xRgSend As Range
    Dim xRgText As Range
    Dim xRgDone As Range
    Dim xOutApp As Object
    Dim xMailItem As Object
    Dim xLastRow As Long
    Dim vbCrLf As String
    Dim xMailBody As String
    Dim xRgDateVal As String
    Dim xRgSendVal As String
    Dim xMailSubject As String
    Dim i As Long
    On Error Resume Next
    Set xRgDate = Application.InputBox("Please select the due date column:", "KuTools For Excel", , , , , , 8)
    If xRgDate Is Nothing Then Exit Sub
    Set xRgSend = Application.InputBox("Please select the recipients?email column:", "KuTools For Excel", , , , , , 8)
    If xRgSend Is Nothing Then Exit Sub
    Set xRgText = Application.InputBox("Select the column with reminded content in your email:", "KuTools For Excel", , , , , , 8)
    If xRgText Is Nothing Then Exit Sub
    xLastRow = xRgDate.Rows.count
    Set xRgDate = xRgDate(1)
    Set xRgSend = xRgSend(1)
    Set xRgText = xRgText(1)
    Set xOutApp = CreateObject("Outlook.Application")
    For i = 1 To xLastRow
        xRgDateVal = ""
        xRgDateVal = xRgDate.Offset(i - 1).Value
        If xRgDateVal <> "" Then
        If CDate(xRgDateVal) - Date <= 7 And CDate(xRgDateVal) - Date > 0 Then
            xRgSendVal = xRgSend.Offset(i - 1).Value
            xMailSubject = xRgText.Offset(i - 1).Value & " on " & xRgDateVal
            vbCrLf = "<br><br>"
            xMailBody = "<HTML><BODY>"
            xMailBody = xMailBody & "Dear " & xRgSendVal & vbCrLf
            xMailBody = xMailBody & "Text : " & xRgText.Offset(i - 1).Value & vbCrLf
            xMailBody = xMailBody & "</BODY></HTML>"
            Set xMailItem = xOutApp.CreateItem(0)
            With xMailItem
                .Subject = xMailSubject
                .To = xRgSendVal
                .HTMLBody = xMailBody
                .Display
                '.Send
            End With
            Set xMailItem = Nothing
        End If
    End If
    Next
    Set xOutApp = Nothing
End Sub

si vous avez des idées je suis preneur !!

merci d'avance pour vos réponses à ce problème plutôt complexe.

Le 08/02/2023 à 11:52

Bonjour

Merci de fournir un fichier test sans données personnelles..

l'adresse du destinataire se trouve où ? dans une cellule ? en dure dans le code ?

merci de confirmer que l'on doit utiliser l'application Outlook pour l'envoi des mails

Fred

Le 08/02/2023 à 11:58

Bonjour Fred le fichier est le suivant en pièce jointe

Oui l'application est outlook et pour le l'emplacement de l'adresse mail peu importe.

je te laisse créer un nouveau module pour faire cette option

le changement de couleur ce fait grâce au bouton sur la page "récap". Ou automatiser dans un userform.

34outils-d-inventaire-version-1-xlsb.xlsm (187.54 Ko)

Le 08/02/2023 à 14:51

Pour ceux que ça intéresse voilà mon code j'ai résolut le problème par moi même

Sub mail()

Dim i As Double
Dim a As Double
Dim xRgSend As Range
Dim xRgText As Range
Dim xRgDone As Range
Dim xRgDate As Range
Dim xOutApp As Object
Dim xMailItem As Object
Dim xLastRow As Long
Dim vbCrLf As String
Dim xMailBody As String
Dim xRgDateVal As String
Dim xRgSendVal As String
Dim xMailSubject As String
Dim vtype As String
Set xOutApp = CreateObject("Outlook.Application")

For a = 5 To 7
For i = 2 To 147

Set xRgSend = Sheets("récap").Cells(177, 1)
 On Error Resume Next
    If Sheets("récap").Cells(i, a).Interior.Color = RGB(255, 0, 0) Then

        Set xRgSend = xRgSend(1)
        Set xRgText = xRgText(1)
        Set xOutApp = CreateObject("Outlook.Application")
                xRgDateVal = xRgDate.Offset(i - 1).Value
                    If CDate(xRgDateVal) - Date <= 7 And CDate(xRgDateVal) - Date > 0 Then
                            xRgSendVal = xRgSend.Offset(i - 1).Value
                        xMailSubject = xRgText.Offset(i - 1).Value & " on " & xRgDateVal
                        vbCrLf = ""

                If a = 5 Then
                    vtype = "Le poinçon "
                    ElseIf a = 6 Then
                        vtype = "La matrice "
                        ElseIf a = 7 Then
                            vtype = "Le dévêtisseur "
                xMailBody = "Bonjour, " & vbNewLine & vbNewLine & _
                vtype & Sheets("récap").Cells(i, 1) & " est bientot en rupture " & vbNewLine & vbNewLine & _
                "Merci de bien vouloir le commander au plus vite. "
            Set xMailItem = xOutApp.CreateItem(0)
                With xMailItem
            .To = xRgSend
            .CC = ""
            .BCC = ""
            .Subject = "Achat outils découpe"
            .Body = xMailBody
            .Display 'or use .Send
End With
Set xMailItem = Nothing
End If
End If
End If
Set xOutApp = Nothing

Next i
Next a

End Sub

Rechercher des sujets similaires à "envoyer mail quand couleur case change vda"