Sheet dans Corps mail

Le 24/09/2020 à 12:19

Bonjour,

J'ai un script pour créé un mail outlook en VBA mais dans le .Body, je voudrais y mettre un Sheet4.Range("A1:J25").value afin de placer une sélection d'une feuille dans le corps du mail.

Voici mon bout de code

' Envoi du mail lors de la création d'un Issue en fonction du Level
Dim OutlookApp As Object
Dim OutlookMail As Object
Dim i As Long

For i = 1 To Range("t_Contacts").Rows.Count
If Range("t_Contacts[Envoi]")(i) = Me.cblevel Then
Set OutlookApp = CreateObject("outlook.application")
Set OutlookMail = OutlookApp.CreateItem(0)
With OutlookMail
.Subject = "NEW INCIDENT REPORT " & " - " & Now
.To = Range("t_Contacts[Email]")(i).Value
.Body = Sheet5.Range("A1:J25").Value

.Display
End With
End If
Next i

Cela ne fonctionne pas.

Pouvez-vous m'aider ?

Merci beaucoup

Le 24/09/2020 à 13:35

Bonjour,

Allez voir sur ce lien :

http://www.rondebruin.nl/win/s1/outlook/bmail2.htm

pour la fonction RangetoHTML.

Sinon, il y a des petits fates de syntaxe (sheet au lieu de sheets) :

Dim OutlookApp As Object
Dim oMail As Object
Dim i As Long

Set OutlookApp = CreateObject("outlook.application")

For i = 1 To Range("t_Contacts").Rows.Count
    If Range("t_Contacts[Envoi]").cells(i) = Me.cblevel Then
        Set oMail = OutlookApp.CreateItem(0)
        With oMail
            .To = Range("t_Contacts[Email]").cells(i).Value
            .Subject = "NEW INCIDENT REPORT " & " - " & Now
            .HTMLBody = RangetoHMTL(Sheets(5).Range("A1:J25"))
            .Display
        End With
        Set oMail = Nothing
    End If
Next i

Set OutlookApp = Nothing

Cordialement,

Le 24/09/2020 à 17:42

Merci pour la réponse mais j'ai vraiment un problème avec mon code et je ne trouve pas

***************************************************************

'Procedure permettant d'ajouter un enregistement dans la base de donnée
Private Sub btnajout_Click()
Dim ligne As ListRow
Dim response As Integer

'On teste que les contôles ont bien été saisie
If Len(Me.txtdate) = 0 Then
Me.LBLMESSAGE = "Veuillez saisir la date d'encodage."
Me.txtdate.SetFocus
ElseIf Len(Me.txtstime) = 0 Then
Me.LBLMESSAGE = "Veuillez entrer l'heure de début d'incident."
Me.txtstime.SetFocus
ElseIf Len(Me.cbsource) = 0 Then
Me.LBLMESSAGE = "Veuillez sélectionner la source de l'incident."
Me.cbsource.SetFocus
ElseIf Len(Me.txtticket) = 0 Then
Me.LBLMESSAGE = "Veuillez entrer le numéro de ticket."
Me.txtticket.SetFocus
ElseIf Len(Me.txtdescription) = 0 Then
Me.LBLMESSAGE = "Veuillez saisir la description de l'incident."
Me.txtdescription.SetFocus
Else 'Si tous les champs sont complet Alors on peut sauvagarder la source

With tb_issues
'On ajoute une ligne au tableau structuré
Set ligne = .ListRows.Add

'On affecte les données du formulaire dans la source
ligne.Range.Columns(1) = CDate(Me.txtdate)
ligne.Range.Columns(2) = CDate(Me.txtstime)
ligne.Range.Columns(5) = CDate(Me.txtetime)
ligne.Range.Columns(7) = CDate(Me.txteotime)
ligne.Range.Columns(6) = Me.txtdtime
ligne.Range.Columns(8) = Me.txtdotime
ligne.Range.Columns(3) = Me.cbsource
ligne.Range.Columns(4) = Me.cblevel
ligne.Range.Columns(5) = Me.txtdescription
ligne.Range.Columns(10) = Me.cboxwav
ligne.Range.Columns(11) = Me.cboxso
ligne.Range.Columns(12) = Me.cboxpick
ligne.Range.Columns(13) = Me.cboxlo
ligne.Range.Columns(14) = Me.cboxsol
ligne.Range.Columns(15) = Me.cboxreceiv
ligne.Range.Columns(16) = Me.cboxreplen
ligne.Range.Columns(17) = Me.cboxlsd
ligne.Range.Columns(19) = Me.txtticket
ligne.Range.Columns(20) = Me.txtbul
ligne.Range.Columns(21) = Me.txtstatus
End With
End If

response = MsgBox("Confirmez-vous la créartion de la fiche d'Incient ?", vbYesNo + vbCritical + vbDefaultButton2, "Confirmation")
If response = vbYes Then

ThisWorkbook.Save

'Création du rapport Mail lors d'un nouvel Issue
Sheets("Rapport Mail New Issue").Range("D7") = Me.txtdate.Value
Sheets("Rapport Mail New Issue").Range("H7") = Me.txtstime.Value
Sheets("Rapport Mail New Issue").Range("D9") = Me.cbsource.Value
Sheets("Rapport Mail New Issue").Range("D11") = Me.cblevel.Value
Sheets("Rapport Mail New Issue").Range("H11") = Me.txtticket.Value
Sheets("Rapport Mail New Issue").Range("D13") = Me.txtdescription.Value
Sheets("Rapport Mail New Issue").Range("C20") = Me.cboxso.Value
Sheets("Rapport Mail New Issue").Range("C22") = Me.cboxwav.Value
Sheets("Rapport Mail New Issue").Range("C24") = Me.cboxlo.Value
Sheets("Rapport Mail New Issue").Range("E20") = Me.cboxpick.Value
Sheets("Rapport Mail New Issue").Range("E22") = Me.cboxsol.Value
Sheets("Rapport Mail New Issue").Range("E24") = Me.cboxreceiv.Value
Sheets("Rapport Mail New Issue").Range("G20") = Me.cboxreplen.Value
Sheets("Rapport Mail New Issue").Range("G22") = Me.cboxlsd.Value
Sheets("Rapport Mail New Issue").Range("G24") = Me.cboxship.Value
Sheets("Rapport Mail New Issue").Range("I20") = Me.cboxinvent.Value
Sheets("Rapport Mail New Issue").Range("I24") = Me.cboxnoimpact.Value

' Envoi du mail lors de la création d'un Issue en fonction du Level
'Déclaration des variables
Dim MaFeuille As Worksheet
Dim Nbligne As Integer
Dim i As Long

For i = 1 To Range("t_Contacts").Rows.Count
If Range("t_Contacts[Envoi]").Cells(i) = Me.cblevel Then

'Affectation des variables
Set MaFeuille = ThisWorkbook.Sheets("Rapport Mail New Issue")
'Désactivation du reffraichissement de l'écran
Application.ScreenUpdating = False

'On calcule le nombre de ligne à prendre dans la feuille à partir de la colonne A
Nbligne = MaFeuille.Range("A" & Application.Rows.Count).End(xlUp).Row
'On sélectionne la plage à copier
MaFeuille.Range("A1:J" & Nbligne).Select
'Avec l'objet MailEnveloppe on envoi dans le corps du mail
With Selection.Parent.MailEnveloppe.Item
.To = Range("t_Contacts[Email]")(i).Value
.Subject = "New Issue Report" & "-" & Now
.Display
End With
CreateObject("Wscript.shell").Popup "La fiche a été sauvée avec succès et la mail a été envoyé", 2, "Message d'information", vbInformation
Application.ScreenUpdating = True
'On vide le formulaire pour une prochaine saisie
Call btnannuler_Click
End If
End Sub

**************

Edit : merci de mettre le code entre balises avec le bouton </>

Merci pour votre aide

Le 24/09/2020 à 23:45

Bonjour,

Et bien, ça en fait des lignes !
Je ne sais pas quoi vous dire. Où est-ce que ça ne marche pas déjà ?

Les formulaires, c'est pas ce que je maitrise le mieux mais je vais déjà le mettre en forme (à l'aide des balises) avec des toutes petites modifs :

Private Sub btnajout_Click()

Dim fRapp as worksheet
Dim ligne As long
Dim response As Integer
Dim Nbligne As Integer
Dim i As Long

'On teste que les contôles ont bien été saisie
If Len(Me.txtdate) = 0 Then
    Me.LBLMESSAGE = "Veuillez saisir la date d'encodage."
    Me.txtdate.SetFocus
    Exit sub '<<<<<<<<<< Exit Sub si validation pas OK (rajouter dans les autres)
end if

If Len(Me.txtstime) = 0 Then
    Me.LBLMESSAGE = "Veuillez entrer l'heure de début d'incident."
    Me.txtstime.SetFocus
end if

If Len(Me.cbsource) = 0 Then
    Me.LBLMESSAGE = "Veuillez sélectionner la source de l'incident."
    Me.cbsource.SetFocus
end if

If Len(Me.txtticket) = 0 Then
    Me.LBLMESSAGE = "Veuillez entrer le numéro de ticket."
    Me.txtticket.SetFocus
end if

If Len(Me.txtdescription) = 0 Then
    Me.LBLMESSAGE = "Veuillez saisir la description de l'incident."
    Me.txtdescription.SetFocus
end if 'Si tous les champs sont complet Alors on peut sauvagarder la source

With tb_issues '<<<< tableau pas défini, est ce normal ? variable publique ?
'On ajoute une ligne au tableau structuré
    .ListRows.Add
    Ligne = .rows.count 'dernière ligne (en principe^^) du tableau
'On affecte les données du formulaire dans la source
    .cells(Ligne, 1) = CDate(Me.txtdate) '<<<<<<<<<< faire pareil avec suite
    ligne.Range.Columns(2) = CDate(Me.txtstime)
    ligne.Range.Columns(5) = CDate(Me.txtetime)
    ligne.Range.Columns(7) = CDate(Me.txteotime)
    ligne.Range.Columns(6) = Me.txtdtime
    ligne.Range.Columns(8) = Me.txtdotime
    ligne.Range.Columns(3) = Me.cbsource
    ligne.Range.Columns(4) = Me.cblevel
    ligne.Range.Columns(5) = Me.txtdescription
    ligne.Range.Columns(10) = Me.cboxwav
    ligne.Range.Columns(11) = Me.cboxso
    ligne.Range.Columns(12) = Me.cboxpick
    ligne.Range.Columns(13) = Me.cboxlo
    ligne.Range.Columns(14) = Me.cboxsol
    ligne.Range.Columns(15) = Me.cboxreceiv
    ligne.Range.Columns(16) = Me.cboxreplen
    ligne.Range.Columns(17) = Me.cboxlsd
    ligne.Range.Columns(19) = Me.txtticket
    ligne.Range.Columns(20) = Me.txtbul
    ligne.Range.Columns(21) = Me.txtstatus
End With

response = MsgBox("Confirmez-vous la création de la fiche d'Incident ?", vbYesNo + vbCritical + vbDefaultButton2, "Confirmation")
If not response = vbYes Then Exit sub 'si reponse autre que oui, fin procedure

ThisWorkbook.Save
set fRapp = Sheets("Rapport Mail New Issue") 
'Création du rapport Mail lors d'un nouvel Issue
with fRapp
    .Range("D7") = Me.txtdate.Value '<<<<<<<< faire pareil avec suite
    .Range("H7") = Me.txtstime.Value
    Sheets("Rapport Mail New Issue").Range("D9") = Me.cbsource.Value
    Sheets("Rapport Mail New Issue").Range("D11") = Me.cblevel.Value
    Sheets("Rapport Mail New Issue").Range("H11") = Me.txtticket.Value
    Sheets("Rapport Mail New Issue").Range("D13") = Me.txtdescription.Value
    Sheets("Rapport Mail New Issue").Range("C20") = Me.cboxso.Value
    Sheets("Rapport Mail New Issue").Range("C22") = Me.cboxwav.Value
    Sheets("Rapport Mail New Issue").Range("C24") = Me.cboxlo.Value
    Sheets("Rapport Mail New Issue").Range("E20") = Me.cboxpick.Value
    Sheets("Rapport Mail New Issue").Range("E22") = Me.cboxsol.Value
    Sheets("Rapport Mail New Issue").Range("E24") = Me.cboxreceiv.Value
    Sheets("Rapport Mail New Issue").Range("G20") = Me.cboxreplen.Value
    Sheets("Rapport Mail New Issue").Range("G22") = Me.cboxlsd.Value
    Sheets("Rapport Mail New Issue").Range("G24") = Me.cboxship.Value
    Sheets("Rapport Mail New Issue").Range("I20") = Me.cboxinvent.Value
    Sheets("Rapport Mail New Issue").Range("I24") = Me.cboxnoimpact.Value
end with

' Envoi du mail lors de la création d'un Issue en fonction du Level
For i = 1 To Range("t_Contacts").Rows.Count
    If Range("t_Contacts[Envoi]").Cells(i) = Me.cblevel Then

'Désactivation du reffraichissement de l'écran
Application.ScreenUpdating = False

'On calcule le nombre de ligne à prendre dans la feuille à partir de la colonne A
        Nbligne = fRapp.Range("A" & Application.Rows.Count).End(xlUp).Row
'On sélectionne la plage à copier
        fRapp.Range("A1:J" & Nbligne).Select
'Avec l'objet MailEnveloppe on envoi dans le corps du mail
        With Selection.Parent.MailEnveloppe.Item '????? connais pas !!! outlook pas instancié ni declaré ???
            .To = Range("t_Contacts[Email]").cells(i).Value
            .Subject = "New Issue Report" & "-" & Now
            .HTMLBody = ""
            .Display
        End With
        CreateObject("Wscript.shell").Popup "La fiche a été sauvée avec succès et la mail a été envoyé", 2, "Message d'information", vbInformation
    end if
next i

Application.ScreenUpdating = True

'On vide le formulaire pour une prochaine saisie
    Call btnannuler_Click

End Sub

Bon j'ai mis des petits commentaires pour vous guider afin de le rendre un peu plus propre. Ce code, il faut le tester pour voir où il pose problème. Ca pourrait même être bien de le séquencer : appeler successivement des macros (ex : macro validation puis macro remplissage tableau puis mail)... Sinon, c'est lourd.

Par ailleurs, je ne sais pas quel est l'ordre de tabulation de vos contrôles d'userform mais il y aurait le moyen de faire une boucle plutôt que d'écrire 20 lignes...

Bon courage,

Rechercher des sujets similaires à "sheet corps mail"