Inserer le document Excel en piece jointe d'un mail

Le 30/10/2024 à 09:26

Bonjour,

Je me lance d'un projet pour facilité la vie a tous le monde sauf que je me retrouve bloquer.

j'ai réussi a créer le mails avec les informations du tableur excel mais je voudrais que le fichier excel s'enregistre aussi en pièce jointe en reprenant les Information contenu dans la cellule D4 & D7 . Pouvez-vous m'aider ? :)

Voici mon code :

Sub EmailWorkbook()
Dim SourceWB As Workbook
Dim DestinWB As Workbook
Dim OutlookApp As Object
Dim OutlookMessage As Object
Dim TempFileName As Variant
Dim ExternalLinks As Variant
Dim TempFilePath As String
Dim FileExtStr As String
Dim DefaultName As String
Dim UserAnswer As Long
Dim strbody As String
Dim strsubject As String
Dim strheader As String
Dim x As Long
Dim SUBMISSIONROW As Long
Dim SUBMISSIONCOLUMN As Long
Dim SUBMITMESSAGE As String
Dim STORENAME As String
Dim oOutlook As Object
Dim KIMBALL As String
Dim FILEDATE As String

On Error Resume Next
Set oOutlook = GetObject(, "Outlook.Application")
On Error GoTo 0

If oOutlook Is Nothing Then
Shell ("OUTLOOK")
End If

Set SourceWB = ActiveWorkbook
'Determine Temporary File Path
TempFilePath = Environ$("temp") & "\"

'Determine Default File Name for InputBox
If SourceWB.Saved Then
DefaultName = Left(SourceWB.Name, InStrRev(SourceWB.Name, ".") - 1)
Else
DefaultName = SourceWB.Name
End If

'Create Instance of Outlook
On Error Resume Next
Set OutlookApp = GetObject(class:="Outlook.Application") 'Handles if Outlook is already open
err.Clear

If OutlookApp Is Nothing Then Set OutlookApp = CreateObject(class:="Outlook.Application") 'If not, open Outlook
If Err.Number = 429 Then
MsgBox "Outlook could not be found, aborting.", 16, "Outlook Not Found"
GoTo ExitSub
End If
On Error GoTo 0

'Create a new email message
Set OutlookMessage = OutlookApp.CreateItem(0)

'Ask user for a file name
TempFileName = strsubject

'Determine File Extension
If SourceWB.Saved = True Then
FileExtStr = "." & LCase(Right(SourceWB.Name, Len(SourceWB.Name) - InStrRev(SourceWB.Name, ".", , 1)))
Else
FileExtStr = ".xlsm"
End If

'Optimize Code

Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False

'Save Temporary Workbook
SourceWB.SaveCopyAs TempFilePath & TempFileName & FileExtStr

'Save Changes
If Time() < "17:00:00" Then
strheader = "Bonjour,"
Else
strheader = "Bonsoir,"
End If

strbody = strheader & vbNewLine & vbNewLine & "Ci joint les documents concernant l'évement du " & Range("D5").Text & " qui c'est déroulé à " & Range("D6").Text & " impliquant " & Range("D7").Text & " qui travaille à " & Range("D8").Text & " chez nous ." & "Pendant " & Range("D10").Text & " jours"
strbody = strbody & vbNewLine & vbNewLine & "Vous trouverez en pièce jointe l'extraction M en format PDF reprenant ses jours réelle de la période de J-1 a J+1."
strbody = strbody & vbNewLine & vbNewLine & "Nous restons a votre disposition pour toutes informations complémentaire."
strbody = strbody & vbNewLine & vbNewLine & "Cordialement,"

'Create Outlook email with attachment
On Error Resume Next
With OutlookMessage
.To = "email 1"
'.To = " email 1"
.CC =
.BCC = "email 2"
.Subject = "Investigation INC-XXX"
.body = strbody
.Attachments.Add DestinWB.FullName
.Display
'.send
'; "email 1"
End With

On Error GoTo 0

'Close & Delete the temporary file
Kill TempFilePath & TempFileName & FileExtStr

'Clear Memory
Set OutlookMessage = Nothing
Set OutlookApp = Nothing
Application.EnableEvents = True
Exit Sub

'Optimize Code
ExitSub:

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

Edit modo : mis codes entre balises

Le 30/10/2024 à 10:03

Bonjour KIBI

Pour commencer, vous auriez dû lire la charte de ce forum comme il vous est demandé à votre inscription
[A LIRE AVANT DE POSTER] Charte du forum et informations utiles

Vous auriez pu/du voir ainsi que le code que vous donnez doit être mis entre balises avec le bouton "</>"

  • Pour plus de lisibilité, utilisez le bouton pour insérer vos codes VBA et vos formules Excel.

Et également

4. Joignez (si possible) un fichier pour augmenter vos chances d'obtenir de l'aide en cliquant sur le bouton Fichier de l'éditeur. Si votre fichier est trop lourd ou contient des données personnelles, créez une version allégée de votre fichier avec juste assez d'informations pour permettre de comprendre votre problème. Dans tous les cas, ne postez JAMAIS de fichiers avec des informations personnelles ou confidentielles (cet utilitaire peut vous aider à les retirer).

Bonne journée

Le 30/10/2024 à 10:06

Bonjour,

Pour faciliter la lecture de votre code veuillez utiliser le bouton "</>"

image

Bonne journée

Le 30/10/2024 à 10:11

Bonjour et bienvenue sur ce forum,

Pour l'utilisation de l'icone </> comme précisé par JExcel2fr, je vous ai corrigé le post pour que vous voyiez

Pour votre souci regardez ce lien qui peut vous aider --> https://forum.excel-pratique.com/s/goto/887492

Crdlt

Le 30/10/2024 à 10:43

Salut Modo Dan

Il aurait même fallut supprimer les lignes vides

Le 30/10/2024 à 10:48

salut JExcel2fr

Il aurait même fallut supprimer les lignes vides

Voilà !

Le 30/10/2024 à 12:56

Bonjour à tous,

je voudrais que le fichier excel s'enregistre aussi en pièce jointe en reprenant les Information contenu dans la cellule D4 & D7

Très bien, mai il y a quoi dans ces cellules , et on fait quoi avec ?

Pour ma part je pense que le destinataire ne doit pas avoir accès au code du classeur, si c'est juste pour avoir un visu sur une ou plusieurs feuilles, alors un PDF fera très bien l'affaire. Dites-nous si c'est bon pour vous.

Le 04/11/2024 à 12:07

Bonjour,

dans les cellules c’est juste la date du rapport et le numéro de l’entreprise pour les insérer dans l’objet du mails.
Un format pdf est envisageable et je suis d’accord avec vous c’est même mieux.

Le 04/11/2024 à 16:36

Re,

Quel est le nom de la feuille ou des feuilles à exporter ?

Combien de pages comprends la ou les feuilles dans la zone d'impression ?

Exemple ci-dessous la zone comprends 4 pages, mais seulement 3 sont utilisées.

000007

Pour bien gérer l'export il vaut mieux définir la zone d'impression.

Voulez-Vous sauvegarder le fichier Pdf, ou bien juste le joindre au courriel ?

Le 04/11/2024 à 22:43

Re,
La zone d’impression est de 15 pages,

L’idée c’est juste de le mettre en pièce jointe (format.pdf) et le nom du fichier s’appelle TRAME investigation

Le 05/11/2024 à 09:53

Bonjour,

C'est le nom de la feuille que je voulais connaître, et pas le nom du fichier.

Le 05/11/2024 à 14:12

Bonjour,

j’ai mis le même nom ^^

Le 05/11/2024 à 20:26

Re,

Cela devrait ressembler à quelque chose comme cela :

Penser à :

  • Dans la procédure EmailWorkbook définir la plage d'impression PRINT_AREA exemple "A1:D200"
  • Dans la fonction ExportFile, vérifier le nom de la feuille pour itemSheet
  • CC et BCC sont des chaines de caractères avec un point-virgule entre les adresses.
'@Description "Procédure principale d'envoie."
Sub EmailWorkbook(ByVal RecipientMail As Variant, _
                  Optional ByVal CarbonCopy As Variant, _
                  Optional ByVal BlindCarbonCopy As Variant, _
                  Optional Subject As String, _
                  Optional Display As Boolean = False)

    If Subject = vbNullString Then Subject = "Investigation INC-XXX"

    Const TEMPORARY_FORMAT As String = "_yyyymmddhhmmss"
    Const PRINT_AREA As String = "A1:A150"

    ' // Create Instance of Outlook
    On Error Resume Next
    Dim OutlookApp As Object
    Set OutlookApp = GetObject(class:="Outlook.Application") 'Handles if Outlook is already open
    Err.Clear

    If OutlookApp Is Nothing Then Set OutlookApp = CreateObject(class:="Outlook.Application") 'If not, open Outlook
    If Err.Number = 429 Then
        MsgBox "Outlook could not be found, aborting.", 16, "Outlook Not Found"
        GoTo ExitSub
    End If
    On Error GoTo Catch

    ' // Create a new email message
    Dim OutlookMessage As Object
    Set OutlookMessage = OutlookApp.CreateItem(0)

    ' // Export file
    Dim DefaultName As String
    DefaultName = Split(ThisWorkbook.Name, ".")(0)

    Dim TempFileName As Variant
    TempFileName = ExportFile(DefaultName, PRINT_AREA)

    If IsError(TempFileName) Then
        DisplayError TempFileName
        GoTo Catch
    End If

    ' // Optimize Code
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.DisplayAlerts = False

    ' // Save Changes
    If Time() < #5:00:00 PM# Then
        Dim Header As String
        Header = "Bonjour,"
    Else
        Header = "Bonsoir,"
    End If

    Dim Body As String
    Body = Header & vbNewLine & vbNewLine & "Ci-joint les documents concernant l'évènement du " & Range("D5").Text & " qui c'est déroulé à " & Range("D6").Text & _
           " impliquant " & Range("D7").Text & " qui travaille à " & Range("D8").Text & " chez nous ." & "Pendant " & Range("D10").Text & " jours"
    Body = Body & vbNewLine & vbNewLine & "Vous trouverez en pièce jointe l'extraction M au format PDF reprenant ses jours réels de la période de J-1 a J+1."
    Body = Body & vbNewLine & vbNewLine & "Nous restons à votre disposition pour toutes informations complémentaire."
    Body = Body & vbNewLine & vbNewLine & "Cordialement,"

    ' // Create Outlook email with attachment
    With OutlookMessage
        .to = RecipientMail
        .CC = CarbonCopy
        .BCC = BlindCarbonCopy
        .Subject = Subject
        .Body = Body
        .Attachments.Add TempFileName
        If Display Then
            .Display
        Else
            .Send
        End If
    End With

    'Close & Delete the temporary file
    If TempFileName > vbNullString Then Kill TempFileName

Finally:
    If Not OutlookMessage Is Nothing Then Set OutlookMessage = Nothing
    If Not OutlookApp Is Nothing Then Set OutlookApp = Nothing
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Exit Sub

Catch:
    If Err.Number > 0 Then
        'TODO "Make something"
    End If
    Resume Finally
End Sub

'@Description "Procédure d'exportation renvoie le chemin complet du fichier. Sinon l'erreur rencontrée"
Public Function ExportFile(ByVal Value As String, _
                           PrintArea As String, _
                           Optional ByVal OpenAfterPublish As Boolean = False, _
                           Optional ByRef oSheet As Object) As Variant

    On Error GoTo Catch
    Dim itemSheet As Object
    Set itemSheet = oSheet
    If itemSheet Is Nothing Then Set itemSheet = ThisWorkbook.Worksheets("TRAME investigation")

    If Not itemSheet Is Nothing Then

        Const PATTERN As String = "_yyyymmddhhmmss"

        ReDim SaveProperties(1) As Variant
        SaveProperties(0) = Application.EnableEvents
        SaveProperties(1) = Application.ScreenUpdating
        Application.ScreenUpdating = False
        Application.EnableEvents = False

        ' // Nom de fichier temporaire
        Value = Value & Format(Now, PATTERN)

        Dim FileName As String
        FileName = Environ$("temp") & "\" & Value & ".pdf"

        With itemSheet
            ReDim Preserve SaveProperties(2)
            SaveProperties(2) = .Visible
            If .Visible <> xlSheetVisible Then .Visible = xlSheetVisible

            .PageSetup.PrintArea = PrintArea
            .ExportAsFixedFormat Type:=xlTypePDF, _
                                 FileName:=FileName, _
                                 Quality:=xlQualityStandard, IncludeDocProperties:=False, _
                                 IgnorePrintAreas:=False, From:=1, to:=15, OpenAfterPublish:=OpenAfterPublish
            .Visible = SaveProperties(2)
        End With
        ExportFile = FileName

    Else
        ExportFile = CVErr(xlErrRef)
    End If

Finally:
    Application.EnableEvents = SaveProperties(0)
    Application.ScreenUpdating = SaveProperties(1)
    Exit Function

Catch:
    If Err.Number = 1004 Then
        ExportFile = CVErr(xlErrValue)
    Else
        ExportFile = CVErr(xlErrRef)
    End If
    Resume Finally
End Function

'@Description "Affiche les messages d'erreur."
Private Sub DisplayError(ErrorType As Variant)
    Select Case CVErr(ErrorType)
        Case xlErrRef
            MsgBox "Oupss... Nous avons rencontré un problème d'exportation, la feuille TRAME investigation est introuvable." & vbNewLine & _
                   "Vous l'avez peut-être déplacée, renommée ou supprimée !" & vbNewLine & _
                   "" & vbNewLine & _
                   "La procédure va être suspendue."
        Case xlErrValue
            MsgBox "Oupss... Nous avons rencontré un problème d'exportation, vérifier que le chemin d'exportation est valide." & vbNewLine & _
                   "" & vbNewLine & _
                   "La procédure va être suspendue."
    End Select

End Sub

Pas pu le tester donc dites moi si vous rencontrez un problème.

Bonne programmation.

Rechercher des sujets similaires à "inserer document piece jointe mail"