Fonction mail en VBA

Bonjour à tous,

J'utilise un code VBA qui me convient bien mais j'aimerai l’optimiser pour gagner en rapidité et y rajouter un élément.

Sub Bouton_unique_DI()

'Archivage du formulaire vers l'onglet "Sauvegarde des DI"

Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual

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
Dim sNomFic As String, sRep As String, WshShell As Object

i = 5
Do While Sheets("Sauvegarde_DI").Range("D" & i).Value <> ""
i = i + 1
Loop
With Sheets("Demande_d'Intervention")
.Range("J17").Copy
Sheets("Sauvegarde_DI").Range("E" & i).PasteSpecial Paste:=xlPasteValues
.Range("J19").Copy
Sheets("Sauvegarde_DI").Range("D" & i).PasteSpecial Paste:=xlPasteValues
.Range("J21").Copy
Sheets("Sauvegarde_DI").Range("I" & i).PasteSpecial Paste:=xlPasteValues
.Range("I24").Copy
Sheets("Sauvegarde_DI").Range("F" & i).PasteSpecial Paste:=xlPasteValues
.Range("M24").Copy
Sheets("Sauvegarde_DI").Range("G" & i).PasteSpecial Paste:=xlPasteValues
.Range("G27").Copy
Sheets("Sauvegarde_DI").Range("H" & i).PasteSpecial Paste:=xlPasteValues
.Range("L45").Copy
Sheets("Sauvegarde_DI").Range("M" & i).PasteSpecial Paste:=xlPasteValues
.Range("I45").Copy
Sheets("Sauvegarde_DI").Range("K" & i).PasteSpecial Paste:=xlPasteValues
.Range("I47").Copy
Sheets("Sauvegarde_DI").Range("L" & i).PasteSpecial Paste:=xlPasteValues
.Range("M49").Copy
Sheets("Sauvegarde_DI").Range("J" & i).PasteSpecial Paste:=xlPasteValues
Sheets("Demande_d'Intervention").Select
End With

' Créer une instance Windows Script pour retrouver le chemin du bureau

Set WshShell = CreateObject("WScript.Shell")
sRep = WshShell.SpecialFolders("Desktop")
Set WshShell = Nothing

' Définit le nom du fichier à enregistrer

sNomFic = "Demande d'intervention.pdf"

' Enregistrer la feuille en PDF

ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=sRep & "\" & sNomFic, _
Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=False

Set OutApp = CreateObject("outlook.application")
Set OutMail = OutApp.CreateItem(0)
    With OutMail
        .To = ""
        .Cc = ""
        .Attachments.Add (sRep & "\" & sNomFic)
        .Subject = "Demande d'intervention - "
        .Body = "Bonjour" & Chr(13) & Chr(13) & "Ci-joint, la demande d'intervention au format PDF."
        .Display
    End With

Kill (sRep & "\" & sNomFic)

'Bouton permattant d'effacer les cellules demandées

Range("J17:L17,J19:K19,J21,G27:N41,L45:M45,I47:K47").ClearContents
ActiveWorkbook.Save

Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic

End Sub

J'ai besoin de rajouter dans l'objet du mail le chiffre noté en cellule J19 de la feuille "Demande_d'Intervention" et de-même lors de l'enregistrement en PDF.

Merci de votre aide :)

Bonjour,

A tester !...

Cdlt.

Option Explicit

Public Sub Bouton_unique_DI()
Dim ws As Worksheet, ws2 As Worksheet
Dim OutApp As Object, OutMail As Object, WshShell As Object
Dim sNomFic As String, sRep As String
Dim i As Long

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

    Set ws = Worksheets("Sauvegarde_DI")
    Set ws2 = Worksheets("Demande_d'Intervention")

    i = 5
    Do While ws.Range("D" & i).Value <> ""
        i = i + 1
    Loop

    ws.Range("E" & i).Value = ws2.Range("J17").Value
    ws.Range("D" & i).Value = ws2.Range("J19").Value
    ws.Range("I" & i).Value = ws2.Range("J21").Value
    ws.Range("F" & i).Value = ws2.Range("I24").Value
    ws.Range("G" & i).Value = ws2.Range("M24").Value
    ws.Range("H" & i).Value = ws2.Range("G27").Value

    Set WshShell = CreateObject("WScript.Shell")
    sRep = WshShell.SpecialFolders("Desktop")
    Set WshShell = Nothing

    sNomFic = "Demande d'intervention " & ws2.Range("J19").Value & ".pdf"

    ws.ExportAsFixedFormat _
            Type:=xlTypePDF, _
            Filename:=sRep & "\" & sNomFic, _
            Quality:=xlQualityStandard, _
            IncludeDocProperties:=True, _
            IgnorePrintAreas:=False, _
            OpenAfterPublish:=False

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

    With OutMail
        .To = ""
        .Cc = ""
        .Attachments.Add (sRep & "\" & sNomFic)
        .Subject = "Demande d'intervention " & ws2.Range("J19").Value
        .Body = "Bonjour" & Chr(13) & Chr(13) & "Ci-joint, la demande d'intervention au format PDF."
        .Display
    End With

    Kill (sRep & "\" & sNomFic)

    Range("J17:L17,J19:K19,J21,G27:N41,L45:M45,I47:K47").ClearContents
    ActiveWorkbook.Save

    Set WshShell = Nothing: Set OutApp = Nothing: Set OutMail = Nothing

    With Application
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
    End With

End Sub

Bonjour,

Merci de ton aide, mais l'application du code fait que j'ai une barre de chargement qui met un temps de malade.

Re,

Je n'ai jamais eu cette barre !...

Et surtout pas avec ce type de macro.

As-tu un fichier à joindre ?

Cdlt.

Re,

C'est tes numéros de rames avec / qui génère une erreur.

Essaie :

sNomFic = "Demande d'intervention " & Replace(ws2.Range("J19").Value, "/", "-") & ".pdf"

Cdlt.

J'ai exactement le même problème.

Re,

A tester !?.

Cdlt.

Merci beaucoup !!!

J'ai trouvé mon erreur de débutant.

Bonne journée

Bonjour,

Désolé de te demander ça, mais peux-tu me dire comment je peux incorporer en plus la date du jour dans l'objet du mail ?

Merci par avance

Bonjour,

Modifie ainsi :

Set WshShell = CreateObject("WScript.Shell")
    sRep = WshShell.SpecialFolders("Desktop") & Application.PathSeparator

    sNomFic = sRep & "Demande d'intervention " & Replace(ws2.Range("J19").Value, "/", "-")
    sNomFic = sNomFic & " du " & Format(VBA.Date, "dddd dd mmmm yyyy") & ".pdf"

A te relire.

Cdlt.

Merci