Envoyer un tcd par mail par VBA

Le 04/11/2018 à 12:30

Bonjour,

Par VBA.

Je souhaiterais pouvoir envoyer par mail Le TCD suivant en fonction de l'adresse mail indiqué dans le TCD.

En fait la partie du TCD ou est indiqué l'adresse mail

(avec les étiquettes "ADRESSE MAIL", "NUMERO" "DESIGNATION", "MONTANT") au dessus.

J'ai mis le corps du texte et l'objet sur la page "DANS LE MAIL"

Mon idée est que le mail se prépare avec la partie du TCD pour chaque adresse mail du TCD, le tout en dessous du corps du texte

J'ai beaucoup d'envoi à faire à chaque fois, jusque maintenant je fais tout manuellement.

Je ne sais pas si c'est possible mais sa m'arrangerais beaucoup.

Merci d'avance pour votre aide.

38test.xlsx (16.33 Ko)
Le 04/11/2018 à 13:21

Bonjour,

quel est ton logiciel de messagerie ?

Le 04/11/2018 à 13:35

en attendant ta réponse ... voici le texte à envoyer dans ton mail, en mettant .htmlbody = textemail("ici l'adresse mail") & .htmlbody

Function textemail(qui As String)
Dim Trouve As Range, cel As String
Set Trouve = Sheets("TCD TEST").Range("A:A").Find(what:=qui, LookAt:=xlWhole)
If Trouve Is Nothing Then Exit Function
textemail = ""
With Sheets("DANS LE MAIL ")
    textemail = textemail & .[B4] & "<br> & .[B5]" & "<br><table>"
    i = 0
    cel = Trouve.Offset(i, 1)
    Do Until cel = ""
        textemail = textemail & "<tr><td>" & Trouve.Offset(i, 1) & "</td><td>" & Trouve.Offset(i, 2) & "</td><td>" & Trouve.Offset(i, 3) & "</td></tr>"
        cel = Trouve(i, 1)
        i = i + 1
    Loop
    textemail = "</table><br>" & textemail & .[B7] & "<br>"
End With
End Function
Le 04/11/2018 à 13:47

à tester avec outlook

Function textemail(qui As String)
Dim Trouve As Range, cel As String
Set Trouve = Sheets("TCD TEST").Range("A:A").Find(what:=qui, LookAt:=xlWhole)
If Trouve Is Nothing Then Exit Function
textemail = ""
With Sheets("DANS LE MAIL ")
    textemail = textemail & .[B4] & "<br> & .[B5]" & "<br><table>"
    i = 0
    cel = Trouve.Offset(i, 1)
    Do Until cel = ""
        textemail = textemail & "<tr><td>" & Trouve.Offset(i, 1) & "</td><td>" & Trouve.Offset(i, 2) & "</td><td>" & Trouve.Offset(i, 3) & "</td></tr>"
        cel = Trouve(i, 1)
        i = i + 1
    Loop
    textemail = "</table><br>" & textemail & .[B7] & "<br>"
End With
End Function

Sub envoi()
Dim messagerie As Object
Dim email As Object
Dim dico As Object
Set dico = CreateObject("Scripting.Dictionary")
Set messagerie = CreateObject("Outlook.Application")
    With Sheets("BASE")
        For i = 2 To .Cells(Rows.Count, 1).End(xlUp).Row
            dico(.Cells(i, 2).Value) = ""
        Next
    End With
    For Each Cle In dico.Keys
        Set email = messagerie.CreateItem(0)
        With email
            .to = Cle
            .Subject = Sheets("DANS LE MAIL ").Range("B1")
            .htmlbody = textemail(cel) & .htmlbody
            .ReadReceiptRequested = True
            .display ' à remplacer par .send si ok
        End With
        Set email = Nothing
    Next
Set messagerie = Nothing
End Sub
28test.xlsm (23.53 Ko)
Le 04/11/2018 à 14:02

Bonjour,

Merci de ta réponse.

Ma boite mail est Outlook.

Le code vba bloque sur la deuxième partie

.htmlbody = textemail(cel) & .htmlbody

Cette ligne fait bloquer le macro

Cordialement,

Le 04/11/2018 à 15:09

Désolé, remplace cel par Cle

Le 04/11/2018 à 15:21

Sa ne marche toujours pas cel ou cle sa me met

"erreur de compilation"

"type d'argument ByRef incompatible"

Je sais pas c'est quoi le problème

Cordialement,

Le 04/11/2018 à 15:30

Désolé, n'ayant pas pu tester chez moi ...

voici une correction, en espérant que ce soit ok !

Function textemail(qui As Variant)
Dim Trouve As Range, cel As String
Set Trouve = Sheets("TCD TEST").Range("A:A").Find(what:=qui, LookAt:=xlWhole)
If Trouve Is Nothing Then Exit Function
textemail = ""
With Sheets("DANS LE MAIL ")
    textemail = textemail & .[B4] & "<br> & .[B5]" & "<br><table>"
    i = 0
    cel = Trouve.Offset(i, 1)
    Do Until cel = ""
        textemail = textemail & "<tr><td>" & Trouve.Offset(i, 1) & "</td><td>" & Trouve.Offset(i, 2) & "</td><td>" & Trouve.Offset(i, 3) & "</td></tr>"
        cel = Trouve(i, 1)
        i = i + 1
    Loop
    textemail = "</table><br>" & textemail & .[B7] & "<br>"
End With
End Function

Sub envoi()
Dim messagerie As Object
Dim email As Object
Dim dico As Object
Dim Cle As Variant
Set dico = CreateObject("Scripting.Dictionary")
Set messagerie = CreateObject("Outlook.Application")
    With Sheets("BASE")
        For i = 2 To .Cells(Rows.Count, 1).End(xlUp).Row
            dico(.Cells(i, 2).Value) = ""
        Next
    End With
    For Each Cle In dico.Keys
        Set email = messagerie.CreateItem(0)
        With email
            .to = Cle
            .Subject = Sheets("DANS LE MAIL ").Range("B1")
            .htmlbody = textemail(Cle) & .htmlbody
            .ReadReceiptRequested = True
            .display ' à remplacer par .send si ok
        End With
        Set email = Nothing
    Next
Set messagerie = Nothing
End Sub

je vais chercher une solution pour tester a minima de mon côté

Le 04/11/2018 à 16:47

a priori c'est ok

(je n'ai plus outlook, mais thunderbird, j'avais donc fait un assemblage sans pouvoir tester)

28envoi-mail-a-partir-de-tcd.xlsm (24.92 Ko)
Le 05/11/2018 à 19:03

Bonjour,

Merci pour ton travail mais sa ne marche pas.

Le corps du texte se met pas.

Je veux également les étiquette au dessus (NUMERO - DESIGNATION - MONTANT) et le total en dessous.

Il me manque cette ligne la

- 658452 peinture -26,4.

Sa à l'air très compliqué a faire

Bonjour,

& .[B5]

172452 peinture -50

152688 peinture -70

369256 peinture -80

Cordialement,

Le 05/11/2018 à 19:18

ok, je reprends, tu auras une version fiabilisée demain matin

je reconnais que j'ai pas mal cafouillé n'ayant plus outlook, mais je vais y arriver

Le 05/11/2018 à 19:29

Ok merci, j'espère vraiment tu va y arriver

L'idée c'est de pouvoir envoyer à chaque personne leur détail de virement

exemple pour eric325

Bonjour,

Veuillez trouver ci-joint le détail du dernier virement que nous vous avons fait :

NUMERO DESIGNATION MONTANT

800255 main d'œuvre -20

Total général -20

Cordialement,

Le 06/11/2018 à 01:47

J'espère que cette fois-ci c'est ok

Ensuite, on peut faire les aménagements de forme si nécessaire

72envoi-mail-a-partir-de-tcd.xlsm (25.43 Ko)
Le 06/11/2018 à 19:35

Bonjour,

C'est ok sa marche nickel

Pour la mise en forme je te met ce que je voudrais si c'est possible sinon je ferais avec c'est déjà bien ce que tu as fait.

Je pensais pas que c'était faisable.

Merci beaucoup.

32mise-en-forme.docx (12.72 Ko)
Le 07/11/2018 à 01:47

Bonjour Onnaing,

remplace la fonction par ceci :

Function textemail(qui As Variant)
Dim Trouve As Range
Set Trouve = Sheets("TCD TEST").Range("A:A").Find(what:=qui, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext)
If Trouve Is Nothing Then Exit Function
textemail = ""
With Sheets("DANS LE MAIL ")
    textemail = textemail & .[B4] & "<br>" & .[B5] & "<br><br><table border=1px style=""text-align:center;font-weight:bold;"">"
    textemail = textemail & "<tr><td>&nbsp;&nbsp;&nbsp;NUMERO&nbsp;&nbsp;&nbsp;</td><td>&nbsp;&nbsp;&nbsp;DESIGNATION&nbsp;&nbsp;&nbsp;</td><td>&nbsp;&nbsp;&nbsp;MONTANT&nbsp;&nbsp;&nbsp;</td></tr>"
    i = 0
    Do Until Trouve.Offset(i, 2).Value = ""
        textemail = textemail & "<tr><td style=""color:blue;"">" & Trouve.Offset(i, 1) & "</td><td style=""color:blue;"">" & Trouve.Offset(i, 2) & "</td><td style=""color:blue;"">" & Trouve.Offset(i, 3) & "</td></tr>"
        i = i + 1
    Loop
    textemail = textemail & "<tr><td></td><td>Total</td><td>" & Trouve.Offset(i, 3) & "</td></tr>"
    textemail = textemail & "</table><br>" & .[B7] & "<br><br>"
End With
End Function

Michel_59126

Le 07/11/2018 à 19:16

Bonjour,

Sa marche nickel à part le quadrillage mais bon, c'est bien.

Avec ton aide tu ma fait gagner un temps fou.

C'est bien foutu le VBA.

Merci encore.

Le 07/11/2018 à 22:59
Le 14/11/2018 à 20:53

Steelson,

Tu as fait un truck super, le problème c'est ou je travail sa ne marche pas.

Pourtant j'ai OUTLOOK 2016 aussi.

Quand je lance la Macro, elle se bloque sur le premier envois en me mettant simplement que un bout de tableau.

Je ne comprend pas pas c'est qu'il n' y a pas de DEBOGAGE de la macro donc je sais pas d'ou viens le problème.

Tout conseil et aide et la bienvenue.

Le 14/11/2018 à 22:36

Tu pourrais me faire une copie d'écran de ce qui se passe ? Sinon je ne comprends pas ...

As-tu déjà envoyé des mails à partir d'excel au bureau ? cela dédouanerait déjà une partie du problème.

Cela peut venir aussi de la mise en forme du tableau ?

Le 16/11/2018 à 20:09

Bonjour Steelson,

Non tout est ok c'est de ma faute j'avais ajouter une colonne et sa marcher plus mais la tout marche nikel.

Merci encore pour ton travail.

Cordialement,

Rechercher des sujets similaires à "envoyer tcd mail vba"