XL 2010 Modification code mail

MASSJIPE

MASSJIPE

XLDnaute Impliqué
Bonjour le forum
j'ai un code bricolé pour envoyer un mail.
En T4 il y à la date sous la fonction (=MAINTENANT()) dans la colonne T6 à T500 la date
si la condition si les dates correspondes à T6 il prend les adresses mail en colonne F
peut être revoir le code
Sub envoiMail_debloquage()
'
' envoiMail Macro
' Macro enregistrée le 05/05/2010
'
Dim i As Integer
Dim vehicule As String
Dim BouA As String
Dim signature As String
Dim emetteur As String

signature = "A. Pie<br>115"
emetteur = "toto@sfrt.fr"

i = 6

Do While Range("A" & i).Value <> ""
If Range("G" & i).Value <> 0 Or Range("J" & i).Value <> 0 Then
' Envoi du message d'alerte
strbody = "<html>Bonjour " & Range("E" & i) & "<br><br>"
If Range("C" & i).Value = "A" Then
BouA = "contrôle 25 avant / 25 après"
Else
BouA = "blocage"
End If
strbody = strbody & "tu es pilote du " & BouA & " n°" & Range("B" & i).Value & " (" & Range("D" & i).Value & ") ouvert le " & Range("A" & i).Value & "."
strbody = strbody & "<br>A ce jour, il est fermé :"
strbody = strbody & "<br>Merci de répondre à l'enquête de sastifaction."
strbody = strbody & "<br>1°) Disponibilté des bloqueurs =>"
strbody = strbody & "<br>2°) Délais mise en place cellule de crise =>"
strbody = strbody & "<br>3°) Délai de mise à dispositiondes listings =>"
strbody = strbody & "<br>4°) Traitement des débloquages des véhicules =>"
strbody = strbody & "<br>5°) Autres =>"

strbody = strbody & "<br>" & signature
strbody = strbody & "<br><br>Ceci est un mail automatique envoyé quotidiennement à tous les pilotes de blocage."

Set CdoMessage = CreateObject("CDO.Message")
If Range("G" & i).Value + Range("J" & i).Value > 1 Then
vehicule = "véhicules"
Else
vehicule = "véhicule"
End If
With CdoMessage
.Configuration.Fields.Item("") = 2
.Configuration.Fields.Item("") = "smtp.renault.fr"
.Configuration.Fields.Item("") = 25
.Configuration.Fields.Update
.Subject = "enquête de sastifaction suite à bloquage qualité"
.From = emetteur
.To = Range("F" & i).Value
.CC = "a@sfr.fr"
.HTMLBody = strbody
.Send
End With

Set CdoMessage = Nothing
End If
i = i + 1
Loop

MsgBox ("Les mails ont bien été envoyés aux pilotes de blocage")


End Sub
 

Pièces jointes

  • mail.xlsm
    18.9 KB · Affichages: 32
Trier par date Trier par votes
Lone-wolf

Lone-wolf

XLDnaute Barbatruc
Bonjour MASSJIPE

Fait un test avec le fichier modifier. Sinon un autre exemple CDO

VB: 
'À mettre dans un module standard
Option explicit
Public Const ParamSendUsing As String = "http://schemas.microsoft.com/cdo/configuration/sendusing"
Public Const ParamServeur As String = "http://schemas.microsoft.com/cdo/configuration/smtpserver"
Public Const ParamPort As String = "http://schemas.microsoft.com/cdo/configuration/smtpserverport"
Public Const ParamIdentificateur As String = "http://schemas.microsoft.com/cdo/configuration/smtpauthenticate"
Public Const ParamIdentifiant As String = "http://schemas.microsoft.com/cdo/configuration/sendusername"
Public Const ParamMotDePasse As String = "http://schemas.microsoft.com/cdo/configuration/sendpassword"
Public Const ParamSsl As String = "http://schemas.microsoft.com/cdo/configuration/smtpusessl"

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

Sub EnvoiMailCDO()
Dim CdoMessage, CdoConfig, CdoParam
Dim Fichier As String
'Pour le serveur outlook.com
'smpt = smtp-mail.outlook.com
'Port = 25 (ou 587 si 25 est bloqué)
'Authentification:  oui
'Connexion chiffrée: TLS
'Pour GMail: smtp.gmail.com


        Fichier = ThisWorkbook.Path & "\Classeur1.xls"
    Set CdoConfig = CreateObject("CDO.Configuration")

    CdoConfig.Load -1
    Set CdoParam = CdoConfig.Fields

    With CdoParam
    .Item(ParamSendUsing) = 2
    .Item(ParamServeur) = "smtp.live.com"  ' < Ici Hotmail
    .Item(ParamPort) = 25
    .Item(ParamIdentificateur) = "1"
    .Item(ParamIdentifiant) = ""      'Votre Identifiant
    .Item(ParamMotDePasse) = ""       'Votre mot de passe
    .Item(ParamSsl) = "true"
    .Update
    End With

    Set CdoMessage = CreateObject("CDO.Message")
    With CdoMessage
        Set .Configuration = CdoConfig
        .From = ""
        .To = ""
        .CC = "" 'destinataires en copie (CC)
        .BCC = "" 'destinataires en copie cachée (CCI)
        .Subject = "Test Mail CDO"
        .HTMLBody = "<HTML><body><p>Bonjour Messieurs,</p>" _
        & "<p>Veuillez prendre note du fichier en pièce jointe mis à jour.</p>" _
        & "<br><br>Cordialement.<br><br><br><br>" _
        & "<p>Tom Tom</p></body><HTML>"
        .AddAttachment (Fichier)
        .Send
    End With
    Set CdoMessage = Nothing
    Set CdoConfig = Nothing
    Set CdoParam = Nothing
End Sub

Tu peux aussi faire comme ceci, en supprimant les 1ères conditions. Un exemple:

VB: 
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim ligne As Integer, k As Integer
Application.EnableEvents = False
ligne = Range("t" & Rows.Count).End(xlUp).Row
For k = 6 To ligne
If Range("G" & k).Value <> 0 Or Range("J" & k).Value <> 0 And  _
.Range("t" & k) = .Range("t4") Then Call envoisMail_debloquage
Application.EnableEvents = True
End Sub
 

Pièces jointes

  • Copie de mail.xlsm
    19.4 KB · Affichages: 31
  • Copie de mail-2.xlsm
    20.1 KB · Affichages: 36
Dernière édition:
Vote positif 0 Vote négatif
MASSJIPE

MASSJIPE

XLDnaute Impliqué
Bonjour le forum
j'ai changé le code mais celui ci affiche l'enveloppe du mail comment faire pour ne pas afficher cette enveloppe
je pense que c'est cette ligne ActiveWorkbook.EnvelopeVisible = True mais je ne sais pas comment
merci
VB: 
Sub SATISFACTION()
Dim PlageTo As Range, PlageCc As Range, Cel As Range, ToutTo$, ToutCc$
Dim Plage As Range

On Error Resume Next
derLig = Cells(Rows.Count, 2).End(xlUp).Row
Set Plage = Range("A1:E" & derLig)
On Error GoTo 0
Plage.Select
' Affiche le message dans le classeur
ActiveWorkbook.EnvelopeVisible = True
With Sheets("SATISFACTION")
Set PlageTo = .Range("I1:I" & .[A65536].End(2).Row)
Set PlageCc = .Range("I1:I" & .[C65536].End(2).Row)
End With
For Each Cel In PlageTo
If Cel(, 2) = "A" Then ToutTo = ToutTo & ";" & Cel(, 1)
Next
If ToutTo <> "" Then ToutTo = Right(ToutTo, Len(ToutTo) - 1) Else MsgBox "Pas de destinataires": Exit Sub
For Each Cel In PlageCc
If Cel(, 2) = "C" Then ToutCc = ToutCc & ";" & Cel(, 1)
Next
If ToutCc <> "" Then ToutCc = Right(ToutCc, Len(ToutCc) - 1)
With ActiveSheet.MailEnvelope
'"Item" représente un objet Outlook "MailItem".
.Item.To = ToutTo
.Item.CC = ToutCc
.Item.Subject = Range("B4").Value
.Item.display
End With
End Sub
 
Vote positif 0 Vote négatif

Discussions similaires

V
  • Résolu(e)
Microsoft 365 Envoie mail automatique
2
Réponses
17
Affichages
1 K
vby
V
My<3
  • Question
XL 2019 HTML Corps de mail
Réponses
6
Affichages
358
My<3
My<3
R3n0W
  • Résolu(e)
XL 2016 If Not xRgSel Is Nothing Then --> Ne marche pas
Réponses
10
Affichages
235
R3n0W
R3n0W
F
  • Résolu(e)
XL 2019 Enregistrer sous la feuille active dans répertoire du fichier père en vba
2
Réponses
23
Affichages
810
Fabrice16ct
F
N
  • Résolu(e)
XL 2021 Exporter un graphique dans Outlook
Réponses
3
Affichages
227
NLSCt
N
halecs93
  • Question
Microsoft 365 Générer mail via Excel
Réponses
2
Affichages
323
halecs93
halecs93
K
  • Résolu(e)
XL 2019 Probleme codage
Réponses
2
Affichages
260
Kevin42560
K
J
  • Résolu(e)
XL 2013 Macro et script vba : macro s'arrête dès la première condition trouvée
Réponses
11
Affichages
490
Janu44
J
Regueiro
  • Question
Microsoft 365 VBA Transpose
Réponses
11
Affichages
361
sylvanu
sylvanu
S
  • Résolu(e)
XL 2016 problème de filtre dans listbox
2 3 4
Réponses
51
Affichages
1 K
saidoush
S

Membres actuellement en ligne

17 membres et 158 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 576
Messages
2 089 843
Membres
104 289
dernier inscrit
red123