XL 2019 Envoyer mail et pj automatique via bouton

Quicksland

XLDnaute Occasionnel
Bonjour le forum ,

Je souhaiterai que dans mon fichier "GESTION POTS" l'onglet "FICHE POT" soit envoyer en pj
Dans l'onglet "MAIL' il y a déjà la zone des mails ainsi qu'un bouton "ENVOYER MAIL ..."

Merci a tous pour votre aide
 

Pièces jointes

  • GESTION-POTS.xlsm
    106.3 KB · Affichages: 4
Dernière édition:
Solution
Merci @Quicksland
voici la portion de code à modifier
VB:
strDate = ThisWorkbook.Sheets("FICHE POT").Range("C2")
If strDate <> "" Then
    For Each wksSheet In ActiveWorkbook.Worksheets
    
    If wksSheet.Name <> "FICHE POT" Then '=====>> pour exclure la feuille

        For Each rngCel In wksSheet.UsedRange
            If InStr(UCase(CStr(rngCel.Value)), UCase(strDate)) > 0 Then
                Trouve = True
                wksSheet.Activate
                rngCel.Offset(0, 1).Value = "X"
            End If
        Next rngCel
        End If
    Next wksSheet
End If
Cordialement

Sequoyah

XLDnaute Nouveau
Bonjour Quicksland et le Forum,

voici un exemple à tester
VB:
Sub Mail_FichePot()
'https://excel-downloads.com/threads/envoyer-mail-et-pj-automatique-via-bouton.20071717/

    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim Sourcewb As Workbook, Destwb As Workbook
    Dim Dest As String, Corps As String
    Dim TempFilePath As String, TempFileName As String
    Dim RngDest As Range, DestCell As Range
    Dim WksMail As Worksheet
    
    Set WksMail = ThisWorkbook.Sheets("MAIL")
    Set RngDest = WksMail.Range("C3:C12")
    
    Corps = WksMail.Range("C18") & vbNewLine & vbNewLine & _
    WksMail.Range("C19") & vbNewLine & _
    WksMail.Range("C20") & vbNewLine & _
    WksMail.Range("C21") & vbNewLine & _
    WksMail.Range("C22")
    
    Dim OutApp As Object, OutMail As Object

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

    Set Sourcewb = ActiveWorkbook
    
    Sheets("FICHE POT").Copy
    Set Destwb = ActiveWorkbook
    
    TempFilePath = Environ$("temp") & "\"
    TempFileName = "FICHE POT " & Format(Now, "dd-mmm-yy h-mm-ss") 'A' adapter

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    With Destwb
        .SaveAs TempFilePath & TempFileName & ".xlsx"
        On Error Resume Next
        
        For Each DestCell In RngDest
        If DestCell.Value Like "*@*" Then
            If Dest = "" Then
                Dest = DestCell.Value
            Else
                Dest = Dest & ";" & DestCell.Value
            End If
        End If
    Next
    
        With OutMail
            .to = Dest
            .CC = WksMail.Range("C13").Value
            .BCC = WksMail.Range("C14").Value
            .Subject = WksMail.Range("C15").Value
            .Body = Corps
            .Attachments.Add Destwb.FullName
            .Display
            '.Send
        End With
        On Error GoTo 0
        .Close savechanges:=False
    End With
  
    Kill TempFilePath & TempFileName & ".xlsx"

    Set OutMail = Nothing
    Set OutApp = Nothing

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

Quicksland

XLDnaute Occasionnel
Bonjour Quicksland et le Forum,

voici un exemple à tester
VB:
Sub Mail_FichePot()
'https://excel-downloads.com/threads/envoyer-mail-et-pj-automatique-via-bouton.20071717/

    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim Sourcewb As Workbook, Destwb As Workbook
    Dim Dest As String, Corps As String
    Dim TempFilePath As String, TempFileName As String
    Dim RngDest As Range, DestCell As Range
    Dim WksMail As Worksheet
   
    Set WksMail = ThisWorkbook.Sheets("MAIL")
    Set RngDest = WksMail.Range("C3:C12")
   
    Corps = WksMail.Range("C18") & vbNewLine & vbNewLine & _
    WksMail.Range("C19") & vbNewLine & _
    WksMail.Range("C20") & vbNewLine & _
    WksMail.Range("C21") & vbNewLine & _
    WksMail.Range("C22")
   
    Dim OutApp As Object, OutMail As Object

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

    Set Sourcewb = ActiveWorkbook
   
    Sheets("FICHE POT").Copy
    Set Destwb = ActiveWorkbook
   
    TempFilePath = Environ$("temp") & "\"
    TempFileName = "FICHE POT " & Format(Now, "dd-mmm-yy h-mm-ss") 'A' adapter

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    With Destwb
        .SaveAs TempFilePath & TempFileName & ".xlsx"
        On Error Resume Next
       
        For Each DestCell In RngDest
        If DestCell.Value Like "*@*" Then
            If Dest = "" Then
                Dest = DestCell.Value
            Else
                Dest = Dest & ";" & DestCell.Value
            End If
        End If
    Next
   
        With OutMail
            .to = Dest
            .CC = WksMail.Range("C13").Value
            .BCC = WksMail.Range("C14").Value
            .Subject = WksMail.Range("C15").Value
            .Body = Corps
            .Attachments.Add Destwb.FullName
            .Display
            '.Send
        End With
        On Error GoTo 0
        .Close savechanges:=False
    End With
 
    Kill TempFilePath & TempFileName & ".xlsx"

    Set OutMail = Nothing
    Set OutApp = Nothing

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub
Bonjour @Sequoyah ,

Cela fonctionne parfaitement 👍

Serait-il possible d'avoir la même chose mais sans l'ouverture d'Outlook
et avoir un message box comme quoi le mail et la PJ ont été envoyer

et la cerise sur le gâteau serai d'avoir une croix dans la cellule ex: "B4" de l'onglet janvier

Merci pour ton aide

 

Sequoyah

XLDnaute Nouveau
Bonjour @Quicksland,
merci pour ton retour. Voici mon nouvel essai (la cerise m'a coûté plus d'efforts que le gâteau:p)

VB:
Sub Mail_FichePot2()
'https://excel-downloads.com/threads/envoyer-mail-et-pj-automatique-via-bouton.20071717/
    
Dim FileExtStr      As String
Dim FileFormatNum   As Long
Dim Sourcewb        As Workbook, Destwb As Workbook
Dim Dest            As String, Corps As String
Dim TempFilePath    As String, TempFileName As String
Dim RngDest         As Range, DestCell As Range, rngCel As Range, strDate As String
Dim WksMail         As Worksheet, wksSheet As Worksheet
Dim Trouve          As Boolean
Dim OutApp          As Object, OutMail As Object
    
Set WksMail = ThisWorkbook.Sheets("MAIL")
Set RngDest = WksMail.Range("C3:C12")

Corps = WksMail.Range("C18") & vbNewLine & vbNewLine & _
        WksMail.Range("C19") & vbNewLine & _
        WksMail.Range("C20") & vbNewLine & _
        WksMail.Range("C21") & vbNewLine & _
        WksMail.Range("C22")

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

Set Sourcewb = ActiveWorkbook

Sheets("FICHE POT").Copy
Set Destwb = ActiveWorkbook

TempFilePath = Environ$("temp") & "\"
TempFileName = "FICHE POT " & Format(Now, "dd-mmm-yy h-mm-ss")        'A' adapter

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

With Destwb
    .SaveAs TempFilePath & TempFileName & ".xlsx"
    On Error Resume Next
    
    For Each DestCell In RngDest
        If DestCell.Value Like "*@*" Then
            If Dest = "" Then
                Dest = DestCell.Value
            Else
                Dest = Dest & ";" & DestCell.Value
            End If
        End If
    Next
    
    With OutMail
        .to = Dest
        .CC = WksMail.Range("C13").Value
        .BCC = WksMail.Range("C14").Value
        .Subject = WksMail.Range("C15").Value
        .Body = Corps
        .Attachments.Add Destwb.FullName
       ' .Display
       .Send
    End With
    On Error GoTo 0
    .Close savechanges:=False
End With

Kill TempFilePath & TempFileName & ".xlsx"

Set OutMail = Nothing
Set OutApp = Nothing

strDate = ThisWorkbook.Sheets("FICHE POT").Range("C2")
If strDate <> "" Then
    For Each wksSheet In ActiveWorkbook.Worksheets
        For Each rngCel In wksSheet.UsedRange
            If InStr(UCase(CStr(rngCel.Value)), UCase(strDate)) > 0 Then
                Trouve = True
                wksSheet.Activate
                rngCel.Offset(0, 1).Value = "X"
            End If
        Next rngCel
    Next wksSheet
End If

MsgBox "Message envoyé!"

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

End Sub
 

Quicksland

XLDnaute Occasionnel
Bonjour @Quicksland,
merci pour ton retour. Voici mon nouvel essai (la cerise m'a coûté plus d'efforts que le gâteau:p)

VB:
Sub Mail_FichePot2()
'https://excel-downloads.com/threads/envoyer-mail-et-pj-automatique-via-bouton.20071717/
   
Dim FileExtStr      As String
Dim FileFormatNum   As Long
Dim Sourcewb        As Workbook, Destwb As Workbook
Dim Dest            As String, Corps As String
Dim TempFilePath    As String, TempFileName As String
Dim RngDest         As Range, DestCell As Range, rngCel As Range, strDate As String
Dim WksMail         As Worksheet, wksSheet As Worksheet
Dim Trouve          As Boolean
Dim OutApp          As Object, OutMail As Object
   
Set WksMail = ThisWorkbook.Sheets("MAIL")
Set RngDest = WksMail.Range("C3:C12")

Corps = WksMail.Range("C18") & vbNewLine & vbNewLine & _
        WksMail.Range("C19") & vbNewLine & _
        WksMail.Range("C20") & vbNewLine & _
        WksMail.Range("C21") & vbNewLine & _
        WksMail.Range("C22")

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

Set Sourcewb = ActiveWorkbook

Sheets("FICHE POT").Copy
Set Destwb = ActiveWorkbook

TempFilePath = Environ$("temp") & "\"
TempFileName = "FICHE POT " & Format(Now, "dd-mmm-yy h-mm-ss")        'A' adapter

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

With Destwb
    .SaveAs TempFilePath & TempFileName & ".xlsx"
    On Error Resume Next
   
    For Each DestCell In RngDest
        If DestCell.Value Like "*@*" Then
            If Dest = "" Then
                Dest = DestCell.Value
            Else
                Dest = Dest & ";" & DestCell.Value
            End If
        End If
    Next
   
    With OutMail
        .to = Dest
        .CC = WksMail.Range("C13").Value
        .BCC = WksMail.Range("C14").Value
        .Subject = WksMail.Range("C15").Value
        .Body = Corps
        .Attachments.Add Destwb.FullName
       ' .Display
       .Send
    End With
    On Error GoTo 0
    .Close savechanges:=False
End With

Kill TempFilePath & TempFileName & ".xlsx"

Set OutMail = Nothing
Set OutApp = Nothing

strDate = ThisWorkbook.Sheets("FICHE POT").Range("C2")
If strDate <> "" Then
    For Each wksSheet In ActiveWorkbook.Worksheets
        For Each rngCel In wksSheet.UsedRange
            If InStr(UCase(CStr(rngCel.Value)), UCase(strDate)) > 0 Then
                Trouve = True
                wksSheet.Activate
                rngCel.Offset(0, 1).Value = "X"
            End If
        Next rngCel
    Next wksSheet
End If

MsgBox "Message envoyé!"

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

End Sub
😜

Très très bon boulot 👍

Juste un petit soucis ...

Une croix s'invite dans la cellule "G2" de la "fiche pot "

Sinon c'est parfait ;)

Merci pour ton aide
 

Sequoyah

XLDnaute Nouveau
Merci @Quicksland
voici la portion de code à modifier
VB:
strDate = ThisWorkbook.Sheets("FICHE POT").Range("C2")
If strDate <> "" Then
    For Each wksSheet In ActiveWorkbook.Worksheets
    
    If wksSheet.Name <> "FICHE POT" Then '=====>> pour exclure la feuille

        For Each rngCel In wksSheet.UsedRange
            If InStr(UCase(CStr(rngCel.Value)), UCase(strDate)) > 0 Then
                Trouve = True
                wksSheet.Activate
                rngCel.Offset(0, 1).Value = "X"
            End If
        Next rngCel
        End If
    Next wksSheet
End If
Cordialement
 

Quicksland

XLDnaute Occasionnel
Merci @Quicksland
voici la portion de code à modifier
VB:
strDate = ThisWorkbook.Sheets("FICHE POT").Range("C2")
If strDate <> "" Then
    For Each wksSheet In ActiveWorkbook.Worksheets
   
    If wksSheet.Name <> "FICHE POT" Then '=====>> pour exclure la feuille

        For Each rngCel In wksSheet.UsedRange
            If InStr(UCase(CStr(rngCel.Value)), UCase(strDate)) > 0 Then
                Trouve = True
                wksSheet.Activate
                rngCel.Offset(0, 1).Value = "X"
            End If
        Next rngCel
        End If
    Next wksSheet
End If
Cordialement
Vraiment génial !

Rapide et efficace 👍

du très bon boulot ;)

Je te remercie pour l'aide sur la finalisation du projet

bonne soirée
 

Discussions similaires

Réponses
2
Affichages
577
Réponses
1
Affichages
342
Compte Supprimé 979
C
Réponses
1
Affichages
298
Compte Supprimé 979
C

Statistiques des forums

Discussions
314 450
Messages
2 109 726
Membres
110 552
dernier inscrit
jasson