Discussion :

[danbenzi]

Bonjour,

J'ai un code qui me permet d'envoyer une feuille d'un classeur en vba qui fonctionne correctement mais le souci c'est lorsque le destinataire ouvre cette feuille, la fenêtre "activer les macros" s'affiche ainsi "le classeur contient des liens...." s'ouvre. Ce qui n'est pas gênant mais est-ce que l'on peut ajouter un code qui permettrait de désactiver macro et lien pour l'envoi?
Voici le code :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
Option Explicit
 
Sub EnvoiMail()
Application.DisplayAlerts = False   'Supprime l'alerte Enregistrer
Dim objMessage As Variant
'ici on cré le chemin complet de ton fichier qui sera créé plus bas
Dim chemin, nom As String
 chemin = ActiveWorkbook.Path
nom = "Devis.xls"
 
'Copie la feuille dans le fichier à envoyer
ThisWorkbook.ActiveSheet.Copy       '
 
    ActiveSheet.Shapes("Rectangle 8").Visible = False    'Masquer le bouton d'envoi et autres formes
    ActiveSheet.Shapes("CommandButton1").Visible = False
    ActiveSheet.Shapes("Oval 19").Visible = False
    ActiveSheet.Shapes("Rectangle 20").Visible = False
    ActiveSheet.Shapes("Rectangle 21").Visible = False
    ActiveSheet.Shapes("Rectangle 22").Visible = False
 
 'Enregistre le fichier à envoyer avec le nom que l'on a créé plus haut
ActiveWorkbook.SaveAs chemin & "\" & nom
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs nom
'Ferme le fichier
ActiveWorkbook.Close
 Application.DisplayAlerts = True
 Call Procédure_Envoi 'Appel procédure d'envoi
 Kill ActiveWorkbook.Path & "\" & "Devis.xls"
 End Sub
 Sub Procédure_Envoi()
    Dim messageHTML As Variant
    Dim objMessage As Variant
    Dim piece_jointe As Variant
'----------------------------------------crée le fichier à envoyer
On Error GoTo errorHandler
'on cré une instance de la reference "cdo" (message)
Set objMessage = CreateObject("CDO.Message")
 
'avec le message blablabla  blablabla
objMessage.Subject = "Devis" & " " & Range("D10").Value & " " & "du" & " " & Range("B13").Value
objMessage.From = Worksheets("Présentation").Range("K52").Value  'adresse mail de l'expéditeur n'est pas obligatoire
objMessage.To = Worksheets("Présentation").Range("K54").Value 'Email du destinataire doit-être correct ici
objMessage.Cc = Worksheets("Présentation").Range("K56").Value    'Email du destinataire en copie
objMessage.Bcc = Worksheets("Présentation").Range("K58").Value    'Email du destinataire en copie cachée
 
'Crée le corps du message avec insertion de sauts de ligne
objMessage.TextBody = "Bonjour" & " " & Worksheets("Présentation").Range("C62").Value & "," & vbCrLf & vbCrLf _
& "Veuillez trouvez ci-joint le devis du " & Range("D10").Value & "." & vbCrLf & vbCrLf _
& "Cordialement " & vbCrLf _
& Worksheets("Présentation").Range("C66").Value & vbCrLf _
& Worksheets("Présentation").Range("C67").Value & vbCrLf & vbCrLf _
& Worksheets("Présentation").Range("C64").Value & vbCrLf _
& Worksheets("Présentation").Range("K61").Value & vbCrLf _
& Worksheets("Présentation").Range("K62").Value & vbCrLf _
& Worksheets("Présentation").Range("K63").Value & vbCrLf _
& Worksheets("Présentation").Range("K64").Value & vbCrLf & vbCrLf _
& Worksheets("Présentation").Range("K52").Value
 
    piece_jointe = ActiveWorkbook.Path & "\" & "Devis.xls"   ' "Devis.xls"     objMessage.Configuration.Fields.Item _
    ("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
    objMessage.Configuration.Fields.Item _
    ("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.free.fr" 'remplacer ici le smtp par celui de son fournisseur d'accés
    objMessage.Configuration.Fields.Update
    objMessage.AddAttachment (piece_jointe)
    objMessage.Send
 
MsgBox "Le mail a été bien envoyé !" 'Confirmation de l'envoi
 
        'si erreur on sort de la procédure
Exit Sub
errorHandler:
        'description de l'erreur survenue
MsgBox Err.Description
End Sub

Merci d'avance.

Cordialement
Dan

[carden752]

Bonjour,

Une première remarque sur les déclarations

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Dim chemin, nom As String

Correspond à déclarer chemin as variant et nom as string.
La bonne syntaxe est :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Dim chemin As String, nom As String

La macro est raccordée comment au workbook?
Ne serait-il pas possible de l'intégrer dans un module plutôt et utilisable que depuis les ordinateurs qui la lance? Elle ne serait comme cela pas visible pour les destinataires.

[danbenzi]

Bonsoir,

Merci pour la remarque pertinente au sujet des déclarations.
Cette macro est intégré à un module que j'ai appelé "MailDevis" et lance toute la procédure d'envoi. Il y a un code qui me permet de supprimer boutons et formes depuis l'ordi qui lance le programme :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
ActiveSheet.Shapes("Rectangle 8").Visible = False    'Masquer le bouton d'envoi et autres formes
    ActiveSheet.Shapes("CommandButton1").Visible = False
    ActiveSheet.Shapes("Oval 19").Visible = False
    ActiveSheet.Shapes("Rectangle 20").Visible = False
    ActiveSheet.Shapes("Rectangle 21").Visible = False
    ActiveSheet.Shapes("Rectangle 22").Visible = False

je me suis dit que l'on pouvait intégrer un code qui supprimes liens et fixe les valeurs.

A +
Dan

[mercatog]

Bonsoir

Essaies comme ceci

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
Sub EnvoiMail()
Dim Wbk As Workbook
Dim Sh As Worksheet
Dim FichierTemp As String
Dim Shp As Shape
 
Application.ScreenUpdating = False
FichierTemp = ThisWorkbook.Path & "\Devis.xls"
 
ThisWorkbook.ActiveSheet.Copy                                        'Copie la feuille dans le fichier à envoyer
Set Wbk = ActiveWorkbook
Set Sh = ActiveWorkbook.Worksheets(1)
 
For Each Shp In Sh.Shapes
    Shp.Delete
Next Shp
 
With Sh.UsedRange.SpecialCells(xlCellTypeFormulas)
    .Value = .Value
End With
Set Sh = Nothing
 
Application.DisplayAlerts = False                                    'Supprime l'alerte Enregistrer
Wbk.SaveAs FichierTemp                                               'Enregistre le fichier à envoyer avec le nom que l'on a créé plus haut
Application.DisplayAlerts = True
Wbk.Close False                                                      'Ferme le fichier
Set Wbk = Nothing
 
Call Procédure_Envoi                                                 'Appel procédure d'envoi
Kill FichierTemp
End Sub

Edit, Restructure ton code d'envoi ainsi

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
Sub Procedure_Envoi()
Dim objMessage As Object
Dim PieceJointe As String
 
On Error GoTo errorHandler
Set objMessage = CreateObject("CDO.Message")                         'on créé une instance de la reference "cdo" (message)
 
With Worksheets("Présentation")                                      'avec le message blablabla  blablabla
 
    objMessage.Subject = "Devis " & .Range("D10").Value & " du " & .Range("B13").Value
    objMessage.From = .Range("K52").Value                            'adresse mail de l'expéditeur n'est pas obligatoire
    objMessage.To = .Range("K54").Value                              'Email du destinataire doit-être correct ici
    objMessage.Cc = .Range("K56").Value                              'Email du destinataire en copie
    objMessage.Bcc = .Range("K58").Value                             'Email du destinataire en copie cachée
    objMessage.TextBody = "Bonjour " & .Range("C62").Value & "," & vbCrLf & _
                          vbCrLf & "Veuillez trouvez ci-joint le devis du " & .Range("D10").Value & _
                          "." & vbCrLf & vbCrLf & "Cordialement " & vbCrLf & .Range("C66").Value & _
                          vbCrLf & .Range("C67").Value & vbCrLf & vbCrLf & .Range("C64").Value & _
                          vbCrLf & .Range("K61").Value & vbCrLf & .Range("K62").Value & vbCrLf & _
                          .Range("K63").Value & vbCrLf & .Range("K64").Value & vbCrLf & vbCrLf & _
                          .Range("K52").Value                        'Crée le corps du message avec insertion de sauts de ligne
 
End With
 
PieceJointe = ThisWorkbook.Path & "\" & "Devis.xls"                  ' "Devis.xls"     objMessage.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
objMessage.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.free.fr"    'remplacer ici le smtp par celui de son fournisseur d'accés
objMessage.Configuration.Fields.Update
objMessage.AddAttachment PieceJointe
objMessage.Send
Set objMessage = Nothing
 
MsgBox "Le mail a été bien envoyé !"                                 'Confirmation de l'envoi
Exit Sub                                                             'si erreur on sort de la procédure
errorHandler:
MsgBox Err.Description                                               'description de l'erreur survenue
End Sub

[danbenzi]

Bonjour,

J'ai essayé ton code. Une précision que j'ai omis de dire c'est que la feuille a des liens avec d'autres feuilles du classeur et, est protégée donc cela me met un message d'erreur "1004 vous ne pouvez pas exécuter cette commande sur une feuille protégée" à ce niveau:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

With Sh.UsedRange.SpecialCells(xlCellTypeFormulas)

Deuxième souci, lorsque j'ote la protection, il y a une fenêtre qui s'ouvre "fichier spécifié introuvable"

J'ai essayé de voir sans succés.
A + Dan

[mercatog]

Bonjour

je me suis dit que l'on pouvait intégrer un code qui supprimes liens et fixe les valeurs.

Un lien comme ceci =Feuil1!E1 est en fin de compte une formule.

J'ai re-testé le code (avec ajout de dé-protection puis re-protection: Ajoute le mot de passe si tu en as)

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
Sub EnvoiMail()
Dim Wbk As Workbook
Dim Sh As Worksheet
Dim FichierTemp As String
Dim Shp As Shape
 
Application.ScreenUpdating = False
FichierTemp = ThisWorkbook.Path & "\Devis.xls"
 
With ThisWorkbook.ActiveSheet
    .Unprotect
    .Copy                                                            'Copie la feuille dans le fichier à envoyer
    .Protect
End With
Set Wbk = ActiveWorkbook
Set Sh = ActiveWorkbook.Worksheets(1)
 
For Each Shp In Sh.Shapes
    Shp.Delete
Next Shp
 
On Error Resume Next
With Sh.UsedRange.SpecialCells(xlCellTypeFormulas)
    .Value = .Value
End With
On Error GoTo 0
Set Sh = Nothing
 
Application.DisplayAlerts = False                                    'Supprime l'alerte Enregistrer
Wbk.SaveAs FichierTemp                                               'Enregistre le fichier à envoyer avec le nom que l'on a créé plus haut
Application.DisplayAlerts = True
Wbk.Close False                                                      'Ferme le fichier
Set Wbk = Nothing
 
'Call Procédure_Envoi                                                 'Appel procédure d'envoi
'Kill FichierTemp
End Sub

J'ai mis les 2 dernières lignes en commentaire pour tester la création du fichier (sans liaisons)