Envoi email à partir d'excel

Question

Bonjour,
Je viens de créer une macro pour envoyer des emails à partir d'un fichier excel.
Les emails sont expédiés, mais j'ai un problème avec le message.
Je suis débutante et je galère, quelqu'un pourrait t il m'aider s'il vous plait 
Merci

Sub Email()
Dim outlookDossier As Outlook.MAPIFolder
Dim outlookMessage As Outlook.MailItem
Dim vAdresse As String
Dim vObjet As String
Dim vMessage As String
Dim vCellule As Object


For Each vCellule In Range("B4:H19")
    vMessage = "Bonjour" & vCellule & Chr(10)
Next


Range("P2").Select


Do While ActiveCell <> ""
    vAdresse = ActiveCell
    vObjet = Range("B2")
    Set outlookDossier = GetObject("", "Outlook.Application").GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
    Set outlookMessage = outlookDossier.Items.Add
    vMessage = "Bonjour" & Chr(10) & vMessage
    With outlookMessage
        .Subject = vObjet
        .Recipients.Add vAdresse
        .Body = vMessage
        .OriginatorDeliveryReportRequested = True
        .ReadReceiptRequested = True
        .Send
    End With
    ActiveCell.Offset(0, 1) = "x"
    ActiveCell.Offset(1, 0).Select
    Loop
    Set outlookMessage = Nothing
    Set outlookDossier = Nothing
End Sub

jrivet · Answer

Salut,
Tu dis "Les emails sont expédiés, mais j'ai un problème avec le message."
Il serait utile d'expliquer QUEL est ce problème. 

@+: Ju£i?n
Pensez: Réponse acceptée

cs_nanie13 · Answer

Bonjour et merci de me répondre
J'ai rectifié ma macro, cela va mieux, mais j'ai un problème avec le message.
Je frappe donc mon message dans une feuille excel  : ("U3:AA18").
Ce dernier est bien dans mon message, mais chaque ligne est séparé par  6 cm
J'aimerais que cet interligne soit moins important.
Merci pour votre aide

Sub Email()
Dim outlookDossier As Outlook.MAPIFolder
Dim outlookMessage As Outlook.MailItem
Dim vAdresse As String
Dim vObjet As String
Dim vMessage As String
Dim vCellule As Object
For Each vCellule In Range("U3:AA18")
    vMessage = vMessage & vCellule & Chr(10)
Next
Range("O2").Select
Do While ActiveCell <> ""
    vAdresse = ActiveCell
    vObjet = Range("U1")
    Set outlookDossier = GetObject("", "Outlook.Application").GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
    Set outlookMessage = outlookDossier.Items.Add
    With outlookMessage
        .Subject = vObjet
        .Recipients.Add vAdresse
        .Body = vMessage
        .OriginatorDeliveryReportRequested = True
        .ReadReceiptRequested = True
        .Send
    End With
    ActiveCell.Offset(0, 1) = "x"
    ActiveCell.Offset(1, 0).Select
    Loop
    Set outlookMessage = Nothing
    Set outlookDossier = Nothing
End Sub

jrivet · Answer

Re,
ah c'est bizarre car je viens de tester et je n'est pas ce grand ecart entre les lignes.
Cela veut peu être dire que cela ne vient pas forcément du code.
Désolé de ne pas être d'un meilleure aide.

@+: Ju£i?n
Pensez: Réponse acceptée

cs_nanie13 · Answer

Bonjour,
Je viens de trouver mon erreur, il suffisait de noter  ("U3:U18").
Merci

cs_nanie13 · Answer

Re
La macro fonctionne parfaitement, mais je voudrais ajouter des pièces jointes à mon email, quelqu'un pourrait t'il m'aider à trouver  le code s'il vous plait ?

Sub Email()


Dim outlookDossier As Outlook.MAPIFolder
Dim outlookMessage As Outlook.MailItem
Dim vAdresse As String
Dim vObjet As String
Dim vMessage As String
Dim vCellule As Object
Dim PiècesJointes


PiècesJointes = Range("U7")


For Each vCellule In Range("U9:U24")
    vMessage = vMessage & vCellule & Chr(10)
Next
Range("O2").Select
Do While ActiveCell <> ""
    vAdresse = ActiveCell
    vObjet = Range("U5")
    Set outlookDossier = GetObject("", "Outlook.Application").GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
    Set outlookMessage = outlookDossier.Items.Add
    With outlookMessage
        .Subject = vObjet
        .Recipients.Add vAdresse
        .Body = vMessage
        .OriginatorDeliveryReportRequested = True
        .ReadReceiptRequested = True
        .Send
    End With
    ActiveCell.Offset(0, 1) = "x"
    ActiveCell.Offset(1, 0).Select
    Loop
    Set outlookMessage = Nothing
    Set outlookDossier = Nothing
End Sub

Envoi email à partir d'excel

5 réponses

Votre réponse

Discussions similaires