Code VBA outlook

Bonjour,

je poste ci-dessous un code VBA outlook mais il fonctionne pas SOS

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,

Je viens de faire le test sur mon autre PC perso et voilà ce que j'obtiens dans Outlook ce qui me semble être le résultat souhaité :

message outlook mango

Ce qui fais que je ne sais pas comment t'aider plus car le code fonctionne sur les trois PC à ma disposition

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 :

plus de 31 jours

avec la date du 07/12/2019, il passe dans les moins de 31 jours

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

Rechercher des sujets similaires à "code vba outlook"