Erreur envoi fichier avec code VBA

Bonjour,

J'aurais besoin de votre aide car j'ai un fichier Excel avec plusieurs onglets, je clique sur un bouton qui permet de générer un mail avec en pièce jointe un seul onglet sélectionné (voir code ci-après). De mon PC, tout fonctionne parfaitement mais dès que je passe sur un autre PC, ça se complique et je n'y comprends pas grand chose... (le message qui s'affiche d'un PC autre que le mien est le suivant : "Impossible d'exécuter la macro "C:\Users\XXXX(autre utilisateur que moi)\AppData...etc. Il est possible qu'elle ne soit pas disponible dans ce classeur ou que toutes les macros soient désactivées".

Le problème étant que je ne veux pas qu'il cherche une macro sur le PC sur lequel est ouvert l'Excel...

Merci par avance pour votre aide !

Code actuel :

Public Sub New_Book()

Dim ws As Worksheet, strPath As String, strFilename As String

strPath = ThisWorkbook.Path & Application.PathSeparator

Set ws = ThisWorkbook.Worksheets("Base clients")

Set ws2 = ThisWorkbook.Worksheets("1. Fiche")

strFilename = strPath & ws2.Cells(4, 6).Value & " - Fiche d'onboarding client.xlsm"

ws.Copy before:=Workbooks.Add.Worksheets(1)

ActiveWorkbook.SaveAs strFilename, 52

Dim MonOutlook As Object

Dim MonMessage As Object

Dim MonDossier As String

Set MonOutlook = CreateObject("Outlook.Application")

Set MonMessage = MonOutlook.CreateItem(0)

ActiveWorkbook.Save

MonMessage.To = ""

MonMessage.Subject = "Fiche client"

MonMessage.body = "Cher client," & _

Chr(13) & Chr(13) & "Vous trouverez ci-joint votre fiche à compléter." & _

Chr(13) & Chr(13) & "Bien cordialement,"

MonMessage.Attachments.Add ActiveWorkbook.FullName

MonMessage.display

Set MonOutlook = Nothing

End Sub

Bonjour,

Je ne comprends pas trop ton erreur d'exécution.

Essaie ainsi :

Option Explicit

Public Sub New_Book()
Dim wb As Workbook
Dim ws As Worksheet, ws2 As Worksheet
Dim strPath As String, strFilename As String
Dim MonOutlook As Object, MonMessage As Object

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

    With ActiveWorkbook
        strPath = .Path & Application.PathSeparator
        Set ws = .Worksheets("Base clients")
        Set ws2 = .Worksheets("1. Fiche")
    End With
    strFilename = strPath & ws2.Cells(4, 6).Value & " - Fiche d'onboarding client.xlsm"

    ws.Copy
    Set wb = ActiveWorkbook

    Set MonOutlook = CreateObject("Outlook.Application")
    Set MonMessage = MonOutlook.CreateItem(0)

    With wb
        .SaveAs strFilename, 52
        On Error Resume Next
        With MonMessage
            .To = ""
            .Subject = "Fiche client"
            .body = "Cher client," & _
                    Chr(13) & Chr(13) & "Vous trouverez ci-joint votre fiche ? compl?ter." & _
                    Chr(13) & Chr(13) & "Bien cordialement."
            .Attachments.Add wb.FullName
            .Display    'ou .Send
        End With
        On Error GoTo 0
        .Close False
    End With

    Kill strFilename

    Application.EnableEvents = True

    Set MonOutlook = Nothing
    Set MonMessage = Nothing

End Sub

Bonjour Jean-Eric et merci beaucoup pour ton aide (à nouveau)

Ton code semble résoudre une partie du problème en revanche, une fois que le mail avec la fiche Excel en pièce-jointe est généré, quand la personne recevant ce mail ouvre le fichier Excel et qu'elle clique sur un bouton censé ouvrir

un formulaire, ce dernier ne s'ouvre pas et le message d'erreur suivant apparaît (voir PJ)

Jean-Eric a écrit :

Bonjour,

Je ne comprends pas trop ton erreur d'exécution.

Essaie ainsi :

Option Explicit

Public Sub New_Book()
Dim wb As Workbook
Dim ws As Worksheet, ws2 As Worksheet
Dim strPath As String, strFilename As String
Dim MonOutlook As Object, MonMessage As Object

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

    With ActiveWorkbook
        strPath = .Path & Application.PathSeparator
        Set ws = .Worksheets("Base clients")
        Set ws2 = .Worksheets("1. Fiche")
    End With
    strFilename = strPath & ws2.Cells(4, 6).Value & " - Fiche d'onboarding client.xlsm"

    ws.Copy
    Set wb = ActiveWorkbook

    Set MonOutlook = CreateObject("Outlook.Application")
    Set MonMessage = MonOutlook.CreateItem(0)

    With wb
        .SaveAs strFilename, 52
        On Error Resume Next
        With MonMessage
            .To = ""
            .Subject = "Fiche client"
            .body = "Cher client," & _
                    Chr(13) & Chr(13) & "Vous trouverez ci-joint votre fiche ? compl?ter." & _
                    Chr(13) & Chr(13) & "Bien cordialement."
            .Attachments.Add wb.FullName
            .Display    'ou .Send
        End With
        On Error GoTo 0
        .Close False
    End With

    Kill strFilename

    Application.EnableEvents = True

    Set MonOutlook = Nothing
    Set MonMessage = Nothing

End Sub

Re,

Dans le répertoire qu'indique ton message d'erreur, sur mon poste, rien !...

Complétement vide, avant et après avoir exécutée la procédure.

Je viens de tester ma procédure et elle fonctionne sans problème (envoi à 2 adresses différentes et ouverture fichiers sur un PC et un Mac).

Je ne peux pas t'en dire plus.

Cdlt.