Mail personalise

Le 02/05/2019 à 10:40

hello besoin d aide pour envoyer un mail

voila mon probleme j ai en colone F une condition ok ou RDV A PRENDRE

si F = RDV A PRENDRE et colone H vide alors quand je clique sur sur envoi mail (boite de dialogue) alors envoi un mail aux destinataires de la colone I

ca ne fonctionne pas car Outlook occupe

de plus j aimerai inscrire un fois le mail envoye en colone H "ok"

merci de votre aide

Sub MAIL_PERSONNALISE()

Dim Outapp As Object

Dim Outmail As Object

Dim cell As Range

Application.ScreenUpdating = False

Set Outapp = CreateObject("Outlook.Application")

On Error GoTo cleanup

For Each cell In Columns("I").Cells.SpecialCells(xlCellTypeConstants)

If cell.Value Like "?*@?*.?*" And LCase(Cells(cell.Row, "F").Value) = "RDV A PRENDRE" And LCase(Cells(cell.Row, "H").Value) = "" Then

Set Outmail = Outapp.CreateItem(0)

On Error Resume Next

With Outmail

.To = cell.Value

.CC = "xxxxx@mail.com"

.Subject = "Rappel : aptitude médicale arrive à échéance"

paragraphe = ""

paragraphe = paragraphe & "<HEAD>" & Chr(13)

paragraphe = paragraphe & "<BODY>" & Chr(13)

'************************************

paragraphe = paragraphe & "<BR> Attention, votre aptitude médicale arrive à échéance. <BR>" & vbCrLf & vbCrLf

paragraphe = paragraphe & "<BR> Votre EC3 est en fin validité le " & Cells(cell.Row, "F").Value & "<BR> " & vbCrLf & vbCrLf

paragraphe = paragraphe & "<BR>Merci de bien vouloir prendre rdv<BR> " & vbCrLf

paragraphe = paragraphe & "<BR>Animateur de formation<BR> " & vbCrLf

paragraphe = paragraphe & "</BODY>"

paragraphe = paragraphe & ""

.HTMLBody = paragraphe

.Send

End With

On Error GoTo 0

Set Outmail = Nothing

End If

Next cell

cleanup:

Set Outapp = Nothing

Application.ScreenUpdating = True

End Sub

Le 02/05/2019 à 10:42

Bonjour,

Tu dis

ca ne fonctionne pas car Outlook occupe

Pourrais-tu préciser ce que tu veux dire ...?

A quel endroit ta macro s'arrête-t-elle de fonctionner ..?

Le 02/05/2019 à 10:48

cela me marque un autre programme utilise Outlook

veuillez quitter Outlook

la macro ne veut pas s executer ou s execute mais je ne sais pas

il faudrait que je puisse inserer un "ok" pour savoir si cela marche

Le 02/05/2019 à 10:48

cela me marque un autre programme utilise Outlook

veuillez quitter Outlook

la macro ne veut pas s executer ou s execute mais je ne sais pas

il faudrait que je puisse inserer un "ok" pour savoir si cela marche

Le 02/05/2019 à 11:02

Re,

Tu devrais fermer Excel et Outlook ...

Puis ouvrir à nouveau uniquement Excel ... car tu pourrais avoir plusieurs sessions d'Outlook ...

En espèrant que cela t'aide ...

Le 02/05/2019 à 11:13

desole ca ne fonctionne pas

le code est bon ?

Le 02/05/2019 à 11:19

Re,

Visuellement, il n'y a pas d'erreur dans ton code ...

A-t-il déjà fonctionné ou est-ce la première fois que tu l'utilises ...?

Sub MAIL_PERSONNALISE()
Dim Outapp As Object
Dim Outmail As Object
Dim cell As Range
Dim paragraphe As String

Application.ScreenUpdating = False
Set Outapp = CreateObject("Outlook.Application")

On Error GoTo cleanup
  For Each cell In Columns("I").Cells.SpecialCells(xlCellTypeConstants)
    If cell.Value Like "?*@?*.?*" And LCase(Cells(cell.Row, "F").Value) = "RDV A PRENDRE" And LCase(Cells(cell.Row, "H").Value) = "" Then

    Set Outmail = Outapp.CreateItem(0)
    On Error Resume Next
      With Outmail
        .To = cell.Value
        .CC = "xxxxx@mail.com"
        .Subject = "Rappel : Aptitude médicale arrive à échéance"
        paragraphe = ""
        paragraphe = paragraphe & "<HEAD>" & Chr(13)
        paragraphe = paragraphe & "<BODY>" & Chr(13)
        '************************************
        paragraphe = paragraphe & "<BR> Attention, votre aptitude médicale arrive à échéance. <BR>" & vbCrLf & vbCrLf
        paragraphe = paragraphe & "<BR> Votre EC3 est en fin validité le " & Cells(cell.Row, "F").Value & "<BR> " & vbCrLf & vbCrLf
        paragraphe = paragraphe & "<BR>Merci de bien vouloir prendre rdv<BR> " & vbCrLf
        paragraphe = paragraphe & "<BR>Animateur de formation<BR> " & vbCrLf

        paragraphe = paragraphe & "</BODY>"
        paragraphe = paragraphe & ""
        .HTMLBody = paragraphe
        .Send
      End With
    On Error GoTo 0
    Set Outmail = Nothing
    End If
  Next cell

cleanup:
Set Outapp = Nothing
Application.ScreenUpdating = True

End Sub
Le 02/05/2019 à 12:28

Bonjour,

Bonjour James007,

1 - Supprimer la gestion d'erreur Cleanup

2 - LCase renvoie une chaîne convertie en minuscules.

(3 - paragraphe attend semble-t-il une date ?)

Essaie donc ceci en début de procédure :

For Each cell In Columns("I").Cells.SpecialCells(xlCellTypeConstants)
        If cell.Value Like "?*@?*.?*" And LCase(cell.Offset(, -3).Value) = "rdv a prendre" And IsEmpty(cell.Offset(, -1)) Then
          '...
        End If
    Next cell
Le 03/05/2019 à 10:27

cela fonctionne cela envoi le mail

sauf que cela n indique pas de mail en cell.value

cela devrait prendre l adresse mail en I

Le 03/05/2019 à 10:33

Bonjour,

Je ne comprends pas ce que tu écris !...

Peux-tu reformuler ?

Cdlt.

Le 03/05/2019 à 13:30

la fonction envoi mail fonctionne

With Outmail

.To = cell.Value

.CC = "xxxxx@mail.com"

.Subject = "Rappel : Aptitude médicale arrive à échéance"

paragraphe = ""

paragraphe = paragraphe & "<HEAD>" & Chr(13)

paragraphe = paragraphe & "<BODY>" & Chr(13)

'************************************

paragraphe = paragraphe & "<BR> Attention, votre aptitude médicale arrive à échéance. <BR>" & vbCrLf & vbCrLf

paragraphe = paragraphe & "<BR> Votre EC3 est en fin validité le " & Cells(cell.Row, "F").Value & "<BR> " & vbCrLf & vbCrLf

paragraphe = paragraphe & "<BR>Merci de bien vouloir prendre rdv<BR> " & vbCrLf

paragraphe = paragraphe & "<BR>Animateur de formation<BR> " & vbCrLf

paragraphe = paragraphe & "</BODY>"

paragraphe = paragraphe & ""

.HTMLBody = paragraphe

.Send

End With

On Error GoTo 0

Set Outmail = Nothing

End If

mais .To = cell.Value ne prend pas la colonne I la ou il y a les adresses email

For Each cell In Columns("I").Cells.SpecialCells(xlCellTypeConstants)

If cell.Value Like "?*@?*.?*" And LCase(Cells(cell.Row, "F").Value) = "RDV A PRENDRE" And LCase(Cells(cell.Row, "H").Value) = "" Then

Le 17/05/2019 à 09:16

Bonjour

j etais avec Outlook 2010 et ca envoyé le mail juste a CC ,ca ne prenait pas en compte la colonne K

maintenant passage sur excel 2016 et Outlook 2016 et meme probleme je recois sur test.com en CC

rappel du code

colonne H "RDV A PRENDRE" ou rien

colonne L vide ou "OK"

Colonne K liste d adresse email ( K12 a k20)

H L K

Nom Prenom 26/03/20 29/03/20 ok xxx@gmail.com

Nom Prenom 23/02/20 30/11/19 ok xxx@gmail.com

Nom Prenom 13/06/19 08/06/19 RDV A PRENDRE ok xxx@gmail.com

Nom Prenom 20/12/19 27/11/19 ok

Sub MAIL_PERSONNALISE()

Dim Outapp As Object

Dim Outmail As Object

Dim cell As Range

Application.ScreenUpdating = False

Set Outapp = CreateObject("Outlook.Application")

'On Error GoTo cleanup

For Each cell In Columns("K").Cells.SpecialCells(xlCellTypeConstants)

If cell.Value Like "?*@?*.?*" And LCase(Cells(cell.Row, "H").Value) = "RDV A PRENDRE" And LCase(Cells(cell.Row, "J").Value) = "" Then

End If

'For Each cell In Columns("I").Cells.SpecialCells(xlCellTypeConstants)

'If cell.Value Like "?*@?*.?*" And LCase(cell.Offset(, -3).Value) = "RDV A PRENDRE" And IsEmpty(cell.Offset(, -1)) Then

'...

'End If

Next cell

Set Outmail = Outapp.CreateItem(0)

On Error Resume Next

With Outmail

.To = cell.Value

.CC = "test@gmail.com"

.Subject = "Rappel : aptitude médicale arrive à échéance"

paragraphe = ""

paragraphe = paragraphe & "<HEAD>" & Chr(13)

paragraphe = paragraphe & "<BODY>" & Chr(13)

'************************************

paragraphe = paragraphe & "<BR> Attention, votre aptitude médicale arrive à échéance. <BR>" & vbCrLf & vbCrLf

paragraphe = paragraphe & "<BR> Votre EC3 est en fin validité le " & Cells(cell.Row, "F").Value & "<BR> " & vbCrLf & vbCrLf

paragraphe = paragraphe & "<BR>Merci de bien vouloir prendre rdv<BR> " & vbCrLf

paragraphe = paragraphe & "<BR>Animateur de formation<BR> " & vbCrLf

paragraphe = paragraphe & "</BODY>"

paragraphe = paragraphe & ""

.HTMLBody = paragraphe

.Send

End With

On Error GoTo 0

Set Outmail = Nothing

Le 17/05/2019 à 10:54

Bonjour,

essaie ainsi :

Option Explicit

Public Sub Send_Mail()
Dim Outapp As Object, Outmail As Object
Dim ws As Worksheet
Dim Rng As Range, cell As Range
Dim eMail As String, Paragraphe As String

    Set ws = ActiveSheet

    On Error Resume Next
    Set Rng = ws.Columns(11).SpecialCells(2, 2)
    On Error GoTo 0

    If Not Rng Is Nothing Then
        Debug.Print Rng.Address
        Set Outapp = CreateObject("Outlook.Application")
        For Each cell In Rng
            If cell.Value Like "?*@?*.?*" And UCase(cell.Offset(, -3).Value) = "RDV A PRENDRE" And IsEmpty(cell.Offset(, -1)) Then
                eMail = Application.Trim(cell.Value)
                Debug.Print eMail
                Set Outmail = Outapp.CreateItem(0)
                On Error Resume Next
                With Outmail
                    .To = eMail
                    .CC = "test@gmail.com"
                    .Subject = "Rappel : aptitude médicale arrive ? échéance"
                    Paragraphe = ""
                    Paragraphe = Paragraphe & "<HEAD>" & Chr(13)
                    Paragraphe = Paragraphe & "<BODY>" & Chr(13)
                    '************************************
                    Paragraphe = Paragraphe & "<BR> Attention, votre aptitude médicale arrive ? échéance. <BR>" & vbCrLf & vbCrLf
                    Paragraphe = Paragraphe & "<BR> Votre EC3 est en fin validité le " & cell.Offset(, -5).Value & "<BR> " & vbCrLf & vbCrLf
                    Paragraphe = Paragraphe & "<BR>Merci de bien vouloir prendre rdv<BR> " & vbCrLf
                    Paragraphe = Paragraphe & "<BR>Animateur de formation<BR> " & vbCrLf
                    Paragraphe = Paragraphe & "</BODY>"
                    Paragraphe = Paragraphe & ""
                    .HTMLBody = Paragraphe
                    .Send
                End With
                On Error GoTo 0
            End If
            Set Outmail = Nothing
        Next cell
    End If

    Set Outapp = Nothing

End Sub
Rechercher des sujets similaires à "mail personalise"