Envoi Mail VBA avec ListeTo

Bonjour à tous !

Merci encore pour vos précédentes aides, grâce à vous j'avance sur mon projet.
J'ai un nouveau "petit" bug, je pense que ce n'est pas grand chose, mais je ne trouve pas de solution.

Pour résumer :
J'exporte une feuille Excel par le biais d'un bouton relié à une macro. Cela me génère un PDF qui s'attache à mon mail. Précédemment cela marchait bien avec la fonction ListeTo, j'exportait mes cellules directement dans un mail ( corps de message ).

Pour des raisons de taille, je suis maintenant passé à un envoi avec fichier PDF joint, ce qui rend la lecture plus facile et la possibilité pour le destinataire d'imprimer.

Sauf que ma "liste" de destinataires n'est plus prise en compte... Je pense à un souci avec la fonction

With Outmail

, avant cela passait bien avec

 With MyItem

Voici ma macro dans sa totalité, si quelqu'un y voit la solution....

Sub Envoi_CA()

Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim OutApp As Object
Dim OutMail As Object
Dim S As Shape

With Application
    .ScreenUpdating = False
    .EnableEvents = False
End With

Set Sourcewb = ActiveWorkbook

'Copie la feuille active comme nouvelle feuille

ActiveSheet.Copy
Set destwb = ActiveWorkbook

'Désactiver fenêtre de compatibilité
        Application.DisplayAlerts = False
'----------------------------------------------------------------------------
'Sauvegarde la nouvelle feuille/L'envoie par mail/La supprime
'----------------------------------------------------------------------------

TempFilePath = Environ$("temp") & "\"
TempFileName = ActiveSheet.Name

Set OutApp = CreateObject("outlook.application")
Set OutMail = OutApp.CreateItem(0)

With destwb
.ExportAsFixedFormat Type:=xlTypePDF, Filename:=TempFilePath & TempFileName & ".pdf", Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False        ' sauvegarde du fichier au format pdf

    On Error Resume Next
    With OutMail
        .To = ListeTo
        ' .CC = [RH!B3] ' Pour mise en copie ou pas de l'envoi Point Chiffre RR
        .Subject = [POINT_CA!C4] & [POINT_CA!E4] & "" & "  Point Chiffres " & Date & ""
        .Attachments.Add TempFilePath & TempFileName & ".pdf"
        '.Body = "Bonjour, le message a mettre dans le mail "
        .Display 'ou alors utiliser
        '.Send 'pour envoi
    End With
    On Error GoTo 0
    .Close savechanges:=False
End With

    'Effacer le fichier envoyé
Kill TempFilePath & TempFileName & ".pdf"

Set OutMail = Nothing
Set OutApp = Nothing

With Application
    .ScreenUpdating = True
    .EnableEvents = True
    End With

    'Remonte à la cellule de Sélection du Magasin
    Range("A1").Activate
End Sub
Function ListeTo()
'Recuperation des adresses mail pour envoi groupé
    xCpt = 0
    With Sheets("MAGASINS")
        For Each xCell In .Range("B7:B20")
            xCpt = xCpt + 1
            If xCpt = 1 Then
                xTo = xCell
            Else
                xTo = xTo & ";" & xCell
            End If
        Next xCell
    End With
    ListeTo = xTo
End Function

Merci à tous !

bonjour,

pas de problème avec ta fonction listeto() si les destinataires sont bien dans les cellules B7:B20 de la feuille magasins du classeur actif

Merci H2SO,

Ce n'était qu'une suggestion de la cause d'erreur. En tout cas, le liste ne s'incorpore pas à ma liste de destinataire, et je ne vois pas d'où cela pouvait venir à part de là... Merci pour ta réponse, une autre idée ?

re-bonjour,

Selon moi, le problème vient du fait que le classeur actif n'est pas celui qui contient tes destinataires.

peux-tu essayer ainsi ?

Function ListeTo(wb As Workbook)
'Recuperation des adresses mail pour envoi groupé
    xCpt = 0
    With wb.Sheets("MAGASINS")
        For Each xCell In .Range("B7:B20")
            xCpt = xCpt + 1
            If xCpt = 1 Then
                xTo = xCell
            Else
                xTo = xTo & ";" & xCell
            End If
        Next xCell
    End With
    ListeTo = xTo
End Function

et remplacer cette instruction

 .To = ListeTo(Sourcewb)

Merci à toi, je viens juste de trouver la solution....

Je la poste ce dessous, ça peut servir !!

Merci

Function ListeTo()
'Recuperation des adresses mail pour envoi groupé
    xCpt = 0
    With Sheets("MAGASINS")
        For Each xCell In .Range("B7:B20")
            xCpt = xCpt + 1
            If xCpt = 1 Then
                xTo = xCell
            Else
                xTo = xTo & ";" & xCell
            End If
        Next xCell
    End With
    ListeTo = xTo
End Function

Sub Envoi_CA()

' Nécessite la référence : Microsoft Outlook 1x Object Library
Dim olApp As Outlook.Application
Dim olMail As MailItem
Dim CurFile As String
Set olApp = New Outlook.Application
Set olMail = olApp.CreateItem(olMailItem)
CurFile = ThisWorkbook.Path & "\" & "Point CA Magasins.Pdf"
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=CurFile, _
Quality:=xlQualityStandard, IncludeDocProperties:=False, IgnorePrintAreas:=False, _
OpenAfterPublish:=False
With olMail
.To = ListeTo
.CC = ""
.Subject = "Point CA Magasins au :" & Date & ""
.Body = "Vous trouverez ci-joint le fichier PDF ..."
.Attachments.Add CurFile
.Display d
End With

' Effacer les variables objets
Set olMail = Nothing
Set olApp = Nothing
    'Remonte à la cellule de Sélection du Magasin
    Range("A1").Activate
End Sub