Problème avec une macro Excel pour envoyer des fichiers par mail

benadry

XLDnaute Occasionnel
Bonjour le forum,


J'ai réalisé une macro permettant d'envoyer, entre autres, des fichiers Excel par mail.

Le principe est que le contrôleur établit une "fiche anomalie", lui donne un nom automatiquement, et l'envoie ensuite par mail au responsable du Service concerné par l'anomalie.

Je souhaite que :
- le fichier ainsi envoyé soit protégé, de manière à ce que le technicien ne puisse qu'indiquer la date et son nom (cellules B46 et E46) ;
- les macros soient désactivées.

Or, même si le code est présent (FileFormat:=xlOpenXMLWorkbookMacroEnabled
ActiveSheet.Protect "Controle"),
cela ne fonctionne pas.

En effet, les macros sont toujours activées et rien n'est protégé dans la macro.

Si quelqu'un pouvait me donner un coup de main.

Je joins un fichier test et l'ensemble de la macro (voir, plus spécifiquement, la macro Sub EnregImprim()).

Merci d'avance.

Cordialement.


Code:
Sub NumerAuto()

Dim fso As Object, chemin As String, f As Object, i As Integer
Set fso = CreateObject("Scripting.FileSystemObject")
chemin = "G:\XXXX\YYYY\ZZZZ\2013\AAAA\BBBB\"
i = 1
'Cells(i, 1) = "Sous dossiers"
'Cells(i, 2) = "Nb fichiers"
For Each f In fso.GetFolder(chemin).SubFolders
    i = i + 1
    'Cells(i, 1) = f.Name
    Cells(i, 6) = f.Files.Count
    'x = x + f.Files.Count
Next f

End Sub



Sub Enreg()
Dim chemin As String, Chemin2 As String, Repertoire As String, Fichier As String, Fichier2 As String, Fichier4 As String, Rep As String
Dim pl As Range
Dim i As Long
Dim cel As Range


chemin = "G:\XXXX\YYYY\ZZZZ\2013\AAAA\BBBB\"
Chemin2 = "G:\XXXX\YYYY\ZZZZ\2013\AAAA\"

Repertoire = Range("A9").Value & "\"
Fichier = "Test.xlsm"
Fichier2 = Sheets("Feuil2").Range("E1").Value & ".xlsx"
Fichier4 = "Extraction.xlsx"
ActiveWorkbook.SaveAs Filename:=chemin & Repertoire & Fichier2, FileFormat:=xlOpenXMLWorkbookMacroEnabled

With Sheets("Feuil2")
    'définit la plage pl des données que l’on veut importer
    Set pl = Application.Union(.Cells(8, 5), .Cells(9, 1), .Cells(9, 2), .Cells(9, 5), .Cells(13, 2), .Cells(15, 2), .Cells(15, 5), .Cells(17, 2), .Cells(17, 5))
End With

Workbooks.Open Chemin2 & Fichier4
Application.AskToUpdateLinks = False
ActiveWorkbook.UpdateLink Name:=ActiveWorkbook.LinkSources
'Workbooks(Chemin2 & Fichier4).Activate

With ActiveWorkbook.Sheets("Feuil1")
i = .UsedRange.Rows.Count 'compte le nombre de lignes déjà utilisées dans ce fichier
décalageColonne = 0
For Each cel In pl
cel.Copy .Cells(i + 1, 1 + décalageColonne)
décalageColonne = décalageColonne + 1
Next cel
End With

ActiveWorkbook.Close SaveChanges:=True
Rep = MsgBox("Voulez-vous revenir au modèle et fermer la présente fiche anomalie ?", vbYesNo + vbQuestion, "Le programme demande votre attention")
If Rep = vbYes Then
    Workbooks.Open Filename:=chemin & Fichier
    Workbooks(Fichier2).Close SaveChanges:=False
End If
End Sub

Sub EnregImprim()

Dim chemin, Repertoire, Fichier, Fichier2, Rep As String

chemin = "G:\XXXX\YYYY\ZZZZ\2013\AAAA\BBBB\"

Repertoire = [A9].Value & "\"
Fichier = "Test.xlsm"
Fichier2 = Sheets("Feuil2").[E1].Value & ".xlsx"

ActiveWorkbook.SaveAs Filename:=chemin & Repertoire & Fichier2, FileFormat:=xlOpenXMLWorkbookMacroEnabled

ActiveSheet.PrintOut

Rep = MsgBox("Voulez-vous revenir au modèle et fermer la présente fiche anomalie ?", vbYesNo + vbQuestion, "Le programme demande votre attention")
If Rep = vbYes Then
Workbooks.Open Filename:=chemin & Fichier
Workbooks(Fichier2).Close SaveChanges:=False

End If

End Sub

Sub Imprim()


ActiveSheet.PrintOut


End Sub

Sub EnregMail()


Dim chemin, Repertoire, Fichier, Fichier2, Rep, destinataire1, destinataire2, destinataire3, destinataire4, destinataire5, cc, body, sujet, strcommand, fichierjoint As String

destinataire1 = "b.pratiot@zouzou.fr"
destinataire2 = "p.mokal@zouzou.fr"
destinataire3 = "x.boggie@zouzou.fr"
destinataire4 = "p.prazuline@zouzou.fr"
destinataire5 = "c.barchot@zouzou.fr"
cc = "controle@zouzou.fr"
chemin = "G:\XXXX\YYYY\ZZZZ\2013\AAAA\BBBB\"
Repertoire = [A9].Value & "\"
Fichier = "Test.xlsm"
Fichier2 = Sheets("Feuil2").[E1].Value & ".xlsm"
Fichier3 = Sheets("Feuil2").[E1].Value & ".xlsm"
fichierjoint = chemin & Repertoire & Fichier3

ActiveWorkbook.SaveAs Filename:=chemin & Repertoire & Fichier2, FileFormat:=xlOpenXMLWorkbookMacroEnabled
ActiveSheet.Protect "Controle"



If [A9].Value = "A" Then

sujet = "Fiche anomalie"
 
 body = "<HTML><BODY>Bonjour" & "," & "<br>" & "<br>" & "Nous vous prions de trouver ci-joint" & ", " & _
"une fiche anomalie concernant la saisie d'un technicien de votre service." & _
" Nous vous remercions de lui transmettre ladite fiche et de lui demander de régulariser le dossier dans les meilleurs délais." & _
    "<br>" & "<br>" & "<br>" & "Bien cordialement." & "<br>" & "<br>" & "<br>" & "<br>" & "Le Service Contrôle.</BODY></HTML>"

    strcommand = "C:\Program Files\Mozilla Thunderbird\thunderbird"
    strcommand = strcommand & " -compose " & "to='" & destinataire1 & "'"
    strcommand = strcommand & "," & "cc='" & cc & "'"
    strcommand = strcommand & "," & "subject='" & sujet & "',format='1',"
    strcommand = strcommand & "body='" & body & "'"
    strcommand = strcommand & "," & "attachment='file:///" & fichierjoint & "'"

 
Call Shell(strcommand, vbNormalFocus)

End If

If [A9].Value = "B" Then

sujet = "Fiche anomalie"
 
 body = "<HTML><BODY>Bonjour" & "," & "<br>" & "<br>" & "Nous vous prions de trouver ci-joint" & ", " & _
"une fiche anomalie concernant la saisie d'un technicien de votre service." & _
" Nous vous remercions de lui transmettre ladite fiche et de lui demander de régulariser le dossier dans les meilleurs délais." & _
    "<br>" & "<br>" & "<br>" & "Bien cordialement." & "<br>" & "<br>" & "<br>" & "<br>" & "Le Service Contrôle.</BODY></HTML>"

    strcommand = "C:\Program Files\Mozilla Thunderbird\thunderbird"
    strcommand = strcommand & " -compose " & "to='" & destinataire2 & "'"
    strcommand = strcommand & "," & "cc='" & cc & "'"
    strcommand = strcommand & "," & "subject='" & sujet & "',format='1',"
    strcommand = strcommand & "body='" & body & "'"
    strcommand = strcommand & "," & "attachment='file:///" & fichierjoint & "'"

 
Call Shell(strcommand, vbNormalFocus)

End If
 
If [A9].Value = "C" Then

sujet = "Fiche anomalie"
 
 body = "<HTML><BODY>Bonjour" & "," & "<br>" & "<br>" & "Nous vous prions de trouver ci-joint" & ", " & _
"une fiche anomalie concernant la saisie d'un technicien de votre service." & _
" Nous vous remercions de lui transmettre ladite fiche et de lui demander de régulariser le dossier dans les meilleurs délais." & _
    "<br>" & "<br>" & "<br>" & "Bien cordialement." & "<br>" & "<br>" & "<br>" & "<br>" & "Le Service Contrôle.</BODY></HTML>"

    strcommand = "C:\Program Files\Mozilla Thunderbird\thunderbird"
    strcommand = strcommand & " -compose " & "to='" & destinataire3 & "'"
    strcommand = strcommand & "," & "cc='" & cc & "'"
    strcommand = strcommand & "," & "subject='" & sujet & "',format='1',"
    strcommand = strcommand & "body='" & body & "'"
    strcommand = strcommand & "," & "attachment='file:///" & fichierjoint & "'"

 
Call Shell(strcommand, vbNormalFocus)

End If
 
If [A9].Value = "D" Then

sujet = "Fiche anomalie"
 
 body = "<HTML><BODY>Bonjour" & "," & "<br>" & "<br>" & "Nous vous prions de trouver ci-joint" & ", " & _
"une fiche anomalie concernant la saisie d'un technicien de votre service." & _
" Nous vous remercions de lui transmettre ladite fiche et de lui demander de régulariser le dossier dans les meilleurs délais." & _
    "<br>" & "<br>" & "<br>" & "Bien cordialement." & "<br>" & "<br>" & "<br>" & "<br>" & "Le Service Contrôle.</BODY></HTML>"

    strcommand = "C:\Program Files\Mozilla Thunderbird\thunderbird"
    strcommand = strcommand & " -compose " & "to='" & destinataire3 & "'"
    strcommand = strcommand & "," & "cc='" & cc & "'"
    strcommand = strcommand & "," & "subject='" & sujet & "',format='1',"
    strcommand = strcommand & "body='" & body & "'"
    strcommand = strcommand & "," & "attachment='file:///" & fichierjoint & "'"

 
Call Shell(strcommand, vbNormalFocus)

End If
 
 
If [A9].Value = "E" Then

sujet = "Fiche anomalie"
 
 body = "<HTML><BODY>Bonjour" & "," & "<br>" & "<br>" & "Nous vous prions de trouver ci-joint" & ", " & _
"une fiche anomalie concernant la saisie d'un technicien de votre service." & _
" Nous vous remercions de lui transmettre ladite fiche et de lui demander de régulariser le dossier dans les meilleurs délais." & _
    "<br>" & "<br>" & "<br>" & "Bien cordialement." & "<br>" & "<br>" & "<br>" & "<br>" & "Le Service Contrôle.</BODY></HTML>"

    strcommand = "C:\Program Files\Mozilla Thunderbird\thunderbird"
    strcommand = strcommand & " -compose " & "to='" & destinataire4 & "'"
    strcommand = strcommand & "," & "cc='" & cc & "'"
    strcommand = strcommand & "," & "subject='" & sujet & "',format='1',"
    strcommand = strcommand & "body='" & body & "'"
    strcommand = strcommand & "," & "attachment='file:///" & fichierjoint & "'"

 
Call Shell(strcommand, vbNormalFocus)

End If
 
If [A9].Value = "F" Then

sujet = "Fiche anomalie"
 
 body = "<HTML><BODY>Bonjour" & "," & "<br>" & "<br>" & "Nous vous prions de trouver ci-joint" & ", " & _
"une fiche anomalie concernant la saisie d'un technicien de votre service." & _
" Nous vous remercions de lui transmettre ladite fiche et de lui demander de régulariser le dossier dans les meilleurs délais." & _
    "<br>" & "<br>" & "<br>" & "Bien cordialement." & "<br>" & "<br>" & "<br>" & "<br>" & "Le Service Contrôle.</BODY></HTML>"

    strcommand = "C:\Program Files\Mozilla Thunderbird\thunderbird"
    strcommand = strcommand & " -compose " & "to='" & destinataire5 & "'"
    strcommand = strcommand & "," & "cc='" & cc & "'"
    strcommand = strcommand & "," & "subject='" & sujet & "',format='1',"
    strcommand = strcommand & "body='" & body & "'"
    strcommand = strcommand & "," & "attachment='file:///" & fichierjoint & "'"

 
Call Shell(strcommand, vbNormalFocus)

End If

If [A9].Value = "G" Then

sujet = "Fiche anomalie"
 
 body = "<HTML><BODY>Bonjour" & "," & "<br>" & "<br>" & "Nous vous prions de trouver ci-joint" & ", " & _
"une fiche anomalie concernant la saisie d'un technicien de votre service." & _
" Nous vous remercions de lui transmettre ladite fiche et de lui demander de régulariser le dossier dans les meilleurs délais." & _
    "<br>" & "<br>" & "<br>" & "Bien cordialement." & "<br>" & "<br>" & "<br>" & "<br>" & "Le Service Contrôle.</BODY></HTML>"

    strcommand = "C:\Program Files\Mozilla Thunderbird\thunderbird"
    strcommand = strcommand & " -compose " & "to='" & destinataire5 & "'"
    strcommand = strcommand & "," & "cc='" & cc & "'"
    strcommand = strcommand & "," & "subject='" & sujet & "',format='1',"
    strcommand = strcommand & "body='" & body & "'"
    strcommand = strcommand & "," & "attachment='file:///" & fichierjoint & "'"

 
Call Shell(strcommand, vbNormalFocus)

End If


If [A9].Value = "H" Then

sujet = "Fiche anomalie"
 
 body = "<HTML><BODY>Bonjour" & "," & "<br>" & "<br>" & "Nous vous prions de trouver ci-joint" & ", " & _
"une fiche anomalie concernant la saisie d'un technicien de votre service." & _
" Nous vous remercions de lui transmettre ladite fiche et de lui demander de régulariser le dossier dans les meilleurs délais." & _
    "<br>" & "<br>" & "<br>" & "Bien cordialement." & "<br>" & "<br>" & "<br>" & "<br>" & "Le Service Contrôle.</BODY></HTML>"

    strcommand = "C:\Program Files\Mozilla Thunderbird\thunderbird"
    strcommand = strcommand & " -compose " & "to='" & destinataire6 & "'"
    strcommand = strcommand & "," & "cc='" & cc & "'"
    strcommand = strcommand & "," & "subject='" & sujet & "',format='1',"
    strcommand = strcommand & "body='" & body & "'"
    strcommand = strcommand & "," & "attachment='file:///" & fichierjoint & "'"

 
Call Shell(strcommand, vbNormalFocus)

End If



Rep = MsgBox("Voulez-vous revenir au modèle et fermer la présente fiche anomalie ?", vbYesNo + vbQuestion, "Le programme demande votre attention")
If Rep = vbYes Then
Workbooks.Open Filename:=chemin & Fichier
Workbooks(Fichier2).Close SaveChanges:=False

End If

 
End Sub
 

Pièces jointes

  • Test.xlsm
    51.3 KB · Affichages: 51
  • Test.xlsm
    51.3 KB · Affichages: 57
  • Test.xlsm
    51.3 KB · Affichages: 59

benadry

XLDnaute Occasionnel
Re : Problème avec une macro Excel pour envoyer des fichiers par mail

Rebonjour,

Je pense que j'entrevois où est le problème.

En effet, en exécutant la macro pas à pas, je bloque sur la dernière ligne de code ci-dessous (ce qui ne se produit pas quand j'exécute le code d'un seul coup !).

Code:
Sub Enreg()
Dim chemin As String, Chemin2 As String, Repertoire As String, Fichier As String, Fichier2 As String, Fichier4 As String, Rep As String
Dim pl As Range
Dim i As Long
Dim cel As Range


chemin = "G:\XXXX\YYYY\ZZZZ\2013\AAAA\BBBB\"
Chemin2 = "G:\XXXX\YYYY\ZZZZ\2013\AAAA\"

Repertoire = Range("A9").Value & "\"
Fichier = "Test.xlsm"
Fichier2 = Sheets("Feuil2").Range("E1").Value & ".xlsx"
Fichier4 = "Extraction.xlsx"
ActiveWorkbook.SaveAs Filename:=chemin & Repertoire & Fichier2, FileFormat:=xlOpenXMLWorkbookMacroEnabled

J'obtiens le code erreur : "erreur d'exécution 1004. Impossible d'utiliser cette extension avec le type de fichier sélectionné. Modifiez l'extension du fichier dans la zone de texte Nom du fichier ou sélectionnez un autre type de fichier dans la zone type de fichier".

Cela n'est pas étonnant. Cependant, comme dans le fichier ainsi enregistré sous, je n'ai pas besoin de macro, je voudrais les supprimer ou les désactiver et verrouiller les cellules.

Là encore, si quelqu'un pouvait m'aider ...

Merci d'avance.

Cordialement.
 

Discussions similaires

Statistiques des forums

Discussions
311 718
Messages
2 081 866
Membres
101 827
dernier inscrit
kubinou