Code VBA outlook
Bonjour,
je poste ci-dessous un code VBA outlook mais il fonctionne pas
Sub CustomMsgBox(msg)
Set Outlook = CreateObject("Outlook.Application")
Outlook.Navigate "about:blank"
' While Outlook.ReadyState <> 4: WScript.Sleep 100: Wend
ol.Toolbar = False
ol.StatusBar = False
ol.Width = 600
ol.Height = 420
ol.document.body.innerOutlook = "<p class='msg'>" & msg & "</p>" & _
"<p class='ctrl'><input type='hidden' id='OK' name='OK' value='0'>" & _
"<input type='submit' value='OK' id='OKButton' " & _
"onclick='document.all.OK.value=1'></p>"
Set Style = ie.document.CreateStyleSheet
Style.AddRule "p.msg", "font-weight:bold;"
Style.AddRule "p.ctrl", "text-align:rightf;"
Outlook.Visible = True
On Error Resume Next
Do While ie.document.all.OK.Value = 0
WScript.Sleep 200
Loop
Outlook.Quit
End Sub
Private Const COLOR_WINDOWTEXT As Long = 8
Private Const CHANGE_INDEX As Long = 1
Merci par avance
Amicalement
Mango19
Bonjour,
Donc, tu es sur deux forums avec des pseudos différents, lilifer19 et ici Mango19 !
Je t'ai répondu sur l'autre forum te disant que ce que tu cherche à faire ne peut pas fonctionner puisque tu confonds Outlook et Internet Explorer.
Je t'avais donné un code pour Outlook qui chez moi fonctionne très bien donc, je ne vois pas trop ce que tu cherches à faire ?
Bonjour Theze,
Celui qui dit "moi je sais! " est plus ignorant que l'ignorant ; il faut toujours savoir apprendre des autres. Ostad Elahi
Ce proverbe pour expliquer mon inscription sur plusieurs forums.
Effectivement, le tableau que vous m'avez envoyé marche très bien mais j'ai voulu l'améliorer en rajoutant des couleurs par péremption et en modifiant le message du mail via outlook, à savoir je voulais une distinction des péremptions ceux à 1 mois ensemble (couleur rouge), à 2 mois (orange) et 3 mois (vert).
Mais étant novice le résultat est catastrophique. je remets le tableau si vous voulez bien y jeter un œil.
Merci pour votre aide
Mango19
Dans ce cas là, il te faut construire le message de façon complètement différente puisque tu veux du HTML et ensuite, il faut indiquer à Outlook que tu veux écrire en HTML avec la propriété "HTMLBody" !
Tu ne peux pas utiliser le vbCrLf pour aller à la ligne. Voici une piste mais pour que tu ais un résultat, il faut que dans ton tableau il y ait des dates qui génèrent des valeurs compatibles avec tes tests :
Sub Test()
Dim Plage As Range
Dim Cel As Range
Dim DateLimite As Date
Dim Texte As String
Dim Texte1 As String
Dim Texte2 As String
Dim Texte3 As String
With Worksheets("MED PB")
Set Plage = .Range(.Cells(3, 5), .Cells(.Rows.Count, 5).End(xlUp))
DateLimite = .Cells(1, 5).Value
End With
'boucle et construit le texte pour les produits périmés en HTML
For Each Cel In Plage
If Int(DateLimite + 30 - Cel.Value) >= 0 Then
Texte1 = Texte1 & "<b>" & "-" & Cel.Offset(, -4).Value & " " & Cel.Offset(, -3).Value & " " & Cel.Value & "</b><br>"
ElseIf Int(DateLimite + 60 - Cel.Value) >= 0 Then
Texte2 = Texte2 & "<b>" & "-" & Cel.Offset(, -4).Value & " " & Cel.Offset(, -3).Value & " " & Cel.Value & "</b><br>"
ElseIf Int(DateLimite + 90 - Cel.Value) >= 0 Then
Texte3 = Texte3 & "<b>" & "-" & Cel.Offset(, -4).Value & " " & Cel.Offset(, -3).Value & " " & Cel.Value & "</b><br>"
End If
Next Cel
'si le texte est vide, pas de produit périmés, fin de procédure
If Texte1 = "" And Texte2 = "" And Texte3 = "" Then Exit Sub
'début de construction du texte en HTML
Texte = "<html><body><p>Bonjour,</p>"
Texte = Texte & IIf(Texte1 <> "", "<p>Les éléments suivants seront périmés dans moins de 30 jours :<br><font color=Red>" & Texte1 & "</font><br></p>", "")
Texte = Texte & IIf(Texte2 <> "", "<p>Les éléments suivants seront périmés dans moins de 60 jours :<br><font color=orange>" & Texte2 & "</font><br></p>", "")
Texte = Texte & IIf(Texte3 <> "", "<p>Les éléments suivants seront périmés dans moins de 90 jours :<br><font color=green>" & Texte3 & "</font><br></p>", "")
Texte = Texte & "<p>Très cordialement.</p><p>Mango</p></body></html>"
EnvoiMail Texte
End Sub
Sub EnvoiMail(Texte As String)
Dim AppOutlook As Object
Dim OutMail As Object
Set AppOutlook = CreateObject("Outlook.Application")
Set OutMail = AppOutlook.CreateItem(0)
With OutMail
'adresses des deux personnes à adapter !
.To = "adressepersonne_1@orange.fr" & ";" & "adressepersonne_2@orange.fr"
.Subject = "Médicaments périmés. Société MANGO ;-)"
.HTMLBody = Texte 'il te faut indiquer à Outlook que tu veux du HTML !
'affiche le message
.Display
'.Send '<--- enlever l'apostrophe pour que le mail soit envoyé automatiquement !
End With
Set OutMail = Nothing
Set AppOutlook = Nothing
End Sub
Pour mieux comprendre, fais quelques recherches sur le net à propos du HTML, il te faut faire attention car bon nombre de balises demande une balise d'ouverture et une balise de fermeture !
Bon courage
Bonjour,
Afin que tu puisses faire des essais sur le texte en .html et/ou sur les dates sans pour autant lancer Outlook, je t'ai fais un code qui ouvre le fichier .html dans le navigateur par défaut :
Declare Function ShellExecute _
Lib "shell32.dll" _
Alias "ShellExecuteA" ( _
ByVal hWnd As Long, _
ByVal lpOperation As String, _
ByVal lpFile As String, _
ByVal lpParameters As String, _
ByVal lpDirectory As String, _
ByVal nShowCmd As Long) As Long
Sub Test()
Dim Plage As Range
Dim Cel As Range
Dim DateLimite As Date
Dim Texte As String
Dim Texte1 As String
Dim Texte2 As String
Dim Texte3 As String
With Worksheets("MED PB")
Set Plage = .Range(.Cells(3, 5), .Cells(.Rows.Count, 5).End(xlUp))
DateLimite = .Cells(1, 5).Value
End With
'boucle et construit le texte pour les produits périmés en HTML
For Each Cel In Plage
If Int(DateLimite + 30 - Cel.Value) >= 0 Then
Texte1 = Texte1 & "<b>" & "-" & Cel.Offset(, -4).Value & " " & Cel.Offset(, -3).Value & " " & Cel.Value & "</b><br>"
ElseIf Int(DateLimite + 60 - Cel.Value) >= 0 Then
Texte2 = Texte2 & "<b>" & "-" & Cel.Offset(, -4).Value & " " & Cel.Offset(, -3).Value & " " & Cel.Value & "</b><br>"
ElseIf Int(DateLimite + 90 - Cel.Value) >= 0 Then
Texte3 = Texte3 & "<b>" & "-" & Cel.Offset(, -4).Value & " " & Cel.Offset(, -3).Value & " " & Cel.Value & "</b><br>"
End If
Next Cel
'si le texte est vide, pas de produit périmés, fin de procédure
If Texte1 = "" And Texte2 = "" And Texte3 = "" Then Exit Sub
'début de construction du texte en HTML
Texte = "<html><body><p>Bonjour,</p>"
Texte = Texte & IIf(Texte1 <> "", "<p>Les éléments suivants seront périmés dans moins de 30 jours :<br><font color=Red>" & Texte1 & "</font><br></p>", "")
Texte = Texte & IIf(Texte2 <> "", "<p>Les éléments suivants seront périmés dans moins de 60 jours :<br><font color=orange>" & Texte2 & "</font><br></p>", "")
Texte = Texte & IIf(Texte3 <> "", "<p>Les éléments suivants seront périmés dans moins de 90 jours :<br><font color=green>" & Texte3 & "</font><br></p>", "")
Texte = Texte & "<p>Très cordialement.</p><p>Mango</p></body></html>"
'affichage dans le navigateur par défaut
Navigateur Texte
'envoi du mail avec Outlook
'EnvoiMail Texte
End Sub
Sub Navigateur(Texte As String)
Dim Fichier As String
'le fichier texte (qui est un .txt mais enregistré avec l'extansion .html) est enregistré dans le même dossier que le classeur
Fichier = ThisWorkbook.Path & "\Test pour Outlook.html"
Open Fichier For Output As #1: Print #1, Texte: Close #1
'lance le navigateur par défaut
ShellExecute 0, "Open", Fichier, "", vbNullString, 1
End Sub
Sub EnvoiMail(Texte As String)
Dim AppOutlook As Object
Dim OutMail As Object
Set AppOutlook = CreateObject("Outlook.Application")
Set OutMail = AppOutlook.CreateItem(0)
With OutMail
'adresses des deux personnes à adapter !
.To = "adressepersonne_1@orange.fr" & ";" & "adressepersonne_2@orange.fr"
.Subject = "Médicaments périmés. Société MANGO ;-)"
.HTMLBody = Texte 'il te faut indiquer à Outlook que tu veux du HTML !
'affiche le message
.Display
'.Send '<--- enlever l'apostrophe pour que le mail soit envoyé automatiquement !
End With
Set OutMail = Nothing
Set AppOutlook = Nothing
End Sub
Bonsoir Theze,
un immense merci pour votre aide mais je pense que je suis dépassé par le niveau de compétence (je vais prendre des cours).
j'aurai voulu le même tableau que celui en PJ mais avec un envoi par outlook.
Si vous avez la solution je suis prenant sinon je me contenterai de votre premier tableau qui fonctionne très bien.
Merci encore pour votre aide
Bien à vous
Mango19
Bonjour,
Si c'est juste envoyer un petit tableau par mail, tu as cette solution assez simple :
Sub EnvoiMail()
Dim PlgEnvoi As Range
With Worksheets("MED PB")
Set PlgEnvoi = .Range("A2:D10")
PlgEnvoi.Select
ThisWorkbook.EnvelopeVisible = True
With .MailEnvelope
.Item.Subject = "Médicaments périmés. Société MANGO ;-)"
.Introduction = "Bonjour," & _
Chr(13) & Chr(13) & _
"Les produits ci-dessous sont périmés." & _
Chr(13) & Chr(13) & _
"Très cordialement." & _
Chr(13) & Chr(13) & _
"MANGO19"
.Item.To = "destinataire@hebergeur.fr" '<--- adapter l'adresse !
.Item.Send
End With
End With
End Sub
Bonsoir Theze,
Merci Theze pour votre aide, le code que vous m'avez envoyé remplace quoi?
j'ai l'impression qu'il y a deux problèmes :
1) le code couleur
'si le texte est vide, pas de produit périmés, fin de procédure
If Texte1 = "" And texte2 = "" And texte3 = "" Then Exit Sub
'SetSysColors CHANGE_INDEX, COLOR_WINDOWTEXT, vbBlack
CustomMsgBox "Les éléments suivants seront périmés dans moins de 30 jours :<p style='color:red'><br>>" & Texte1 & _
"</p><br>Les éléments suivants seront périmés dans moins de 60 jours :<p style='color:orange'>" & texte2 & _
"</p><br>Les éléments suivants seront périmés dans moins de 90 jours :<p style='color:green'>" & texte3 & "</p>"
'Texte = Left(Texte, Len(Texte) - 3)
'MsgBox Texte
'EnvoiMail Texte
2) le lien avec customMsgBox car il est relié à la couleur et à l'envoi d'un message par IE alors que moi je voudrais un mail en couleur via la boite outlook
Sub CustomMsgBox(msg)
Set ie = CreateObject("InternetExplorer.Application")
ie.Navigate "about:blank"
' While ie.ReadyState <> 4: WScript.Sleep 100: Wend
ie.Toolbar = False
ie.StatusBar = False
ie.Width = 600
ie.Height = 420
ie.document.body.innerHTML = "<p class='msg'>" & msg & "</p>" & _
"<p class='ctrl'><input type='hidden' id='OK' name='OK' value='0'>" & _
"<input type='submit' value='OK' id='OKButton' " & _
"onclick='document.all.OK.value=1'></p>"
Set Style = ie.document.CreateStyleSheet
Style.AddRule "p.msg", "font-weight:bold;"
Style.AddRule "p.ctrl", "text-align:rightf;"
ie.Visible = True
On Error Resume Next
Do While ie.document.all.OK.Value = 0
WScript.Sleep 200
Loop
ie.Quit
End Sub
Cordialement
Mango19
j'aurai voulu le même tableau que celui en PJ mais avec un envoi par outlook.
c'est exactement ce que fais le code que je viens de te donner !
le lien avec customMsgBox car il est relié à la couleur et à l'envoi d'un message par IE alors que moi je voudrais un mail en couleur via la boite outlook
Le code que je t'ai donné le 01 nov. 2019 à 19:39 envoi bien le message en html donc en couleur mais tu as apparemment changé le sens des colonnes donc, voici le code adapté à ton dernier fichier :
Sub Test()
Dim Plage As Range
Dim Cel As Range
Dim DateLimite As Date
Dim Texte As String
Dim Texte1 As String
Dim Texte2 As String
Dim Texte3 As String
With Worksheets("MED PB")
Set Plage = .Range(.Cells(3, 4), .Cells(.Rows.Count, 4).End(xlUp))
DateLimite = .Cells(1, 4).Value
End With
'boucle et construit le texte pour les produits périmés en HTML
For Each Cel In Plage
If Cel.Value < (DateLimite + 30) Then
Texte1 = Texte1 & "<b>" & "-" & Cel.Offset(, -3).Value & " " & Cel.Offset(, -2).Value & " " & Cel.Value & "</b><br>"
ElseIf Cel.Value < (DateLimite + 60) Then
Texte2 = Texte2 & "<b>" & "-" & Cel.Offset(, -3).Value & " " & Cel.Offset(, -2).Value & " " & Cel.Value & "</b><br>"
ElseIf Cel.Value < (DateLimite + 90) Then
Texte3 = Texte3 & "<b>" & "-" & Cel.Offset(, -3).Value & " " & Cel.Offset(, -2).Value & " " & Cel.Value & "</b><br>"
End If
Next Cel
'si le texte est vide, pas de produit périmés, fin de procédure
If Texte1 = "" And Texte2 = "" And Texte3 = "" Then Exit Sub
'début de construction du texte en HTML
Texte = "<html><body><p>Bonjour,</p>"
Texte = Texte & IIf(Texte1 <> "", "<p>Les éléments suivants seront périmés dans moins de 30 jours :<br><font color=Red>" & Texte1 & "</font><br></p>", "")
Texte = Texte & IIf(Texte2 <> "", "<p>Les éléments suivants seront périmés dans moins de 60 jours :<br><font color=orange>" & Texte2 & "</font><br></p>", "")
Texte = Texte & IIf(Texte3 <> "", "<p>Les éléments suivants seront périmés dans moins de 90 jours :<br><font color=green>" & Texte3 & "</font><br></p>", "")
Texte = Texte & "<p>Très cordialement.</p><p>Mango</p></body></html>"
EnvoiMail Texte
End Sub
Sub EnvoiMail(Texte As String)
Dim AppOutlook As Object
Dim OutMail As Object
Set AppOutlook = CreateObject("Outlook.Application")
Set OutMail = AppOutlook.CreateItem(0)
With OutMail
'adresses des deux personnes à adapter !
.To = "adressepersonne_1@orange.fr" & ";" & "adressepersonne_2@orange.fr"
.Subject = "Médicaments périmés. Société MANGO ;-)"
.HTMLBody = Texte 'il te faut indiquer à Outlook que tu veux du HTML !
'affiche le message
.Display
'.Send '<--- enlever l'apostrophe pour que le mail soit envoyé automatiquement !
End With
Set OutMail = Nothing
Set AppOutlook = Nothing
End Sub
Bonjour Theze,
l'envoi via outlook fonctionne mais le résultat donne :
Bonjour,
Les produits ci-dessous sont périmés :
<html><body><p>Bonjour,</p><p>Les éléments suivants seront périmés dans moins de 30 jours :<br><font color=Red><b>-20 PARACETAMOL 21/11/2019</b><br><b>-30 PROPANOLOL 22/11/2019</b><br><b>-60 LOPERAMIDE3 25/11/2019</b><br></font><br></p><p>Les éléments suivants seront périmés dans moins de 60 jours :<br><font color=orange><b>-40 KETOPROFENE 22/12/2019</b><br></font><br></p><p>Les éléments suivants seront périmés dans moins de 90 jours :<br><font color=green><b>-50 IBUPROFENE 23/01/2020</b><br><b>-60 LOPERAMIDE1 24/01/2020</b><br><b>-60 LOPERAMIDE2 25/01/2020</b><br></font><br></p><p>Très cordialement.</p><p>Mango</p></body></html>
un immense merci pour votre aide précieuse
Amicalement
Mango19
Bonjour Theze,
c'est exactement ce que je souhaite mais malgré mes nombreuses tentatives le résultat n'est pas le même que vous
je mets le tableau modifié si vous avez un moment pour le regarder
Merci par avance
Amicalement
Mango19
Quand tu envois un message en html, il ne faut pas utiliser ".body" mais ".HTMLBody" donc, cette partie ci-dessous ne doit plus exister dans le code, c'est de là que vient le problème, il y a conflit :
'construit le message
.body = "Bonjour," & _
Chr(13) & Chr(13) & _
"Les produits ci-dessous sont périmés :" & _
Chr(13) & _
Texte & _
Chr(13) & Chr(13) & _
"Très cordialement." & _
Chr(13) & Chr(13) & _
"MANGO19"
Je te retourne ton fichier avec la suppression des lignes de code :
Bonjour Theze,
un immense immense merci, vous êtes formidable.
Amicalement
Mango19
Bonjour,
Content de t'avoir aidé et que nous soyons arrivés au résultat escompté
Bonjour Theze,
j'aimerai modifier la durée de péremption exemple dans le tableau nous avons + 30 or moi je souhaite plus ou moins 31
j'ai essayé la formuleci dessous mais elle ne fonctionne pas
(DateLimite + 31 - Cel.Value) >= 0 Then
Merci par avance pour votre aide
Amicalement
Mango19
Regardes avec ce code (à cette ligne If Cel.Value < (DateLimite + 30) Then '<--- ici !
) :
Sub Test()
Dim Plage As Range
Dim Cel As Range
Dim DateLimite As Date
Dim Texte As String
Dim Texte1 As String
Dim Texte2 As String
Dim Texte3 As String
With Worksheets("MED PB")
Set Plage = .Range(.Cells(4, 5), .Cells(.Rows.Count, 5).End(xlUp))
DateLimite = .Cells(1, 5).Value
End With
'boucle et construit le texte pour les produits périmés en HTML
For Each Cel In Plage
If Cel.Value < (DateLimite + 30) Then '<--- ici !
Texte1 = Texte1 & "<b>" & "-" & Cel.Offset(, -4).Value & " " & Cel.Offset(, -3).Value & " " & Cel.Value & "</b><br>"
ElseIf Cel.Value < (DateLimite + 60) Then
Texte2 = Texte2 & "<b>" & "-" & Cel.Offset(, -4).Value & " " & Cel.Offset(, -3).Value & " " & Cel.Value & "</b><br>"
ElseIf Cel.Value < (DateLimite + 90) Then
Texte3 = Texte3 & "<b>" & "-" & Cel.Offset(, -4).Value & " " & Cel.Offset(, -3).Value & " " & Cel.Value & "</b><br>"
End If
Next Cel
'si le texte est vide, pas de produit périmés, fin de procédure
If Texte1 = "" And Texte2 = "" And Texte3 = "" Then Exit Sub
'début de construction du texte en HTML
Texte = "<html><body><p>Bonjour,</p>"
Texte = Texte & IIf(Texte1 <> "", "<p>Les éléments suivants seront périmés dans moins de 30 jours :<br><font color=Red>" & Texte1 & "</font><br></p>", "")
Texte = Texte & IIf(Texte2 <> "", "<p>Les éléments suivants seront périmés dans moins de 60 jours :<br><font color=orange>" & Texte2 & "</font><br></p>", "")
Texte = Texte & IIf(Texte3 <> "", "<p>Les éléments suivants seront périmés dans moins de 90 jours :<br><font color=green>" & Texte3 & "</font><br></p>", "")
Texte = Texte & "<p>Très cordialement.</p><p>Mango</p></body></html>"
EnvoiMail Texte
End Sub
Bonjour Theze,
j'ai essayé à l'endroit indiqué mais ça fonctionne pas
'boucle et construit le texte pour les produits périmés en HTML
For Each Cel In Plage
If Int(DateLimite + 31 - Cel.Value) >= 0 Then '<--- ici !
Texte1 = Texte1 & "-" & Cel.Offset(, -4).Value & " " & Cel.Offset(, -3).Value & " " & Cel.Value & vbCrLf
ElseIf Int(DateLimite + 60 - Cel.Value) >= 0 Then
Texte2 = Texte2 & "-" & Cel.Offset(, -4).Value & " " & Cel.Offset(, -3).Value & " " & Cel.Value & vbCrLf
ElseIf Int(DateLimite + 90 - Cel.Value) >= 0 Then
Texte3 = Texte3 & "-" & Cel.Offset(, -4).Value & " " & Cel.Offset(, -3).Value & " " & Cel.Value & vbCrLf
End If
Next Cel
Merci par avance
Amicalement
Mango19
Attention, je viens de voir que la plage est définie qu'à partir de la ligne 4 alors qu'il faut la définir à partir de la ligne 3 donc, cette ligne de code :
Set Plage = .Range(.Cells(4, 5), .Cells(.Rows.Count, 5).End(xlUp))
devient :
Set Plage = .Range(.Cells(3, 5), .Cells(.Rows.Count, 5).End(xlUp))
Au jour d'aujourd'hui (le 07/11/2019) si en E3 tu entres la date du 08/12/2019, la couleur est orange puisqu'il y a 31 jours d'écart car la comparaison est strictement inférieure If Cel.Value < (DateLimite + 31) Then
mais si tu passes au 07/12/2019 (donc 30 jours) la couleur sera rouge !
Voici le résultat en images :
avec la date du 08/12/2019, "-20 PARACETAMOL 08/12/2019" est dans les moins de 60 jours :
avec la date du 07/12/2019, il passe dans les moins de 31 jours
Je n'ai pas rectifié ici le texte "Les éléments suivants seront périmés dans moins de 30 jours" en 31, à toi de le faire chez toi !
Bonsoir Theze,
merci beaucoup pour votre aide
Amicalement
Mango19