Macro pj avec selection zone cellule dans l'onglet

Bonjour,

J'ai réussi à faire une en m'inspirant de la dernière fois et cela fonctionne. Je bidouille mais je ne comprends pas tout...

Voici ce qu'il me manque

Je voudrais enregistrer la copie de l'onglet qu'il fait et qui se nomme "Devis carburant " & Range("nom").Value

dans un répertoire qui se nommerai "envoi devis"

Je souhaite que le nouveau fichier se ferme après que j'ai actionné le bouton envoyé dans outlook.

J'ai également la fenêtre "un programme tente d'envoyer un mail à votre place", peut-on ne plus l'avoir? je suis obligé de cliquer 3 fois de suite!

Je souhaiterai également que les macros soit désactivés lorsque le destinataire reçoit le fichier. J'ai essayé et elle fonctionne toujours car j'ai le bouton de la macro sur cet onglet...

Je souhaiterai envoyer seulement une sélection de l'onglet, est-ce possible?

Merci pour votre aide

Sub Macro1()

ActiveSheet.Copy

ActiveSheet.SaveAs Filename:="Devis carburant " & Range("nom").Value

Dim ObjOutlook As Object

Dim oBjMail

Dim Nom_Fichier As String

Set ol = CreateObject("Outlook.Application")

Set olmail = ol.Application.CreateItem(olMailItem)

Nom_Fichier = Environ("Temp") & "\" & "devis carburant" & " " & Range("nom")

If Nom_Fichier = "" Then Exit Sub

With olmail

.To = "" ' le destinataire

.Subject = "demande de devis carburant-" & [A12] & "" ' l'objet du mail

.HTMLBody = "Bonjour,<br/><br/> Veuillez trouver ci-joint la demande de devis concernant le " & Range("libelle") & ". " & "<br/><br/>L 'offre de prix est à nous retourner " & .HTMLBody 'le corps du mail ..son contenu

.Attachments.Add ActiveWorkbook.Path & "\" & ActiveWorkbook.Name

.ReadReceiptRequested = True

.ReplyRecipients.Add (".fr")

.Display

End With

Set email = Nothing

Set messagerie = Nothing

Exit Sub

erreur:

MsgBox "Erreur : " & Err.Number & vbLf & Err.Description

End Sub

Bonjour Domary,

J'ai apporté quelques modifications à ta macro :

Sub Macro1()
    Const cPath = "C:\envoi_devis"
    Dim oFS As Object
    Dim sWBName As String

    'On s'assure que le dossier de réception des copies existe
    Set oFS = CreateObject("Scripting.FileSystemObject")
    If Not oFS.FolderExists(cPath) Then
        'Sinon, on le créé
        oFS.CreateFolder (cPath)
    End If
    Set oFS = Nothing

    'On affecte le nom de la copie
    sWBName = "Devis carburant " & ".xlsx"
    ActiveSheet.Copy
    'On créé le classeur au format xlsx pour ne pas transporter les macros
    Application.DisplayAlerts = False
    ActiveWorkbook.SaveAs cPath & "\" & sWBName, xlOpenXMLWorkbook
    'On ferme le classeur
    ActiveWorkbook.Close False

    Dim Ol As Object
    Dim OlMail As Object
    Dim Nom_Fichier As String

    Set Ol = CreateObject("Outlook.Application")
    Set OlMail = Ol.Application.CreateItem(1)

    With OlMail
        .Recipients.Add "TheMail@gmail.com" ' le destinataire
        .Subject = "demande de devis carburant-" & [A12] & "" ' l'objet du mail
        .Body = "Bonjour, " & vbCrLf & vbCrLf & "Veuillez trouver ci-joint la demande de devis concernant le " & Range("libelle") & ". " & vbCrLf & vbCrLf & "L 'offre de prix est à nous retourner "  'le corps du mail ..son contenu
        .Attachments.Add cPath & "\" & sWBName
        '.ReadReceiptRequested = True
        .ResponseRequested = True
        '.ReplyRecipients.Add (".fr")
        .Display

    End With
    Set OlMail = Nothing
    Set Ol = Nothing
    Exit Sub

erreur:
    MsgBox "Erreur : " & Err.Number & vbLf & Err.Description
End Sub

A Tester...

Le code transmis devrait résoudre presque tous tes problèmes... sauf les messages de protection envoyé par OUTLOOK.

Si ces messages sont vraiment pénalisants pour toi, un tuto de Ron De Bruin :

http://www.rondebruin.nl/win/s1/security.htm