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
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
| Sub Enregistrer_transmettre_PDF()
'
' Enregistrer_PDF Macro
'
'
Dim fichier As String
Application.ScreenUpdating = False
ActiveSheet.Unprotect Password:="alcoataudon" 'on enlève le mot de passe
With Worksheets("convocs")
.PageSetup.BlackAndWhite = True
.Range("A1:F34").PrintOut
.PageSetup.BlackAndWhite = False
End With
fichier = "C:\Users\xx\Documents\foot\Listing U13 SAISON 2013-2014v2.xlsm" & Range("B1") & " du " & Range("A101") & "" & Range("A102") & "" & Range("A104") & "" & Range("A105") 'on sélectionne le répertoire de destination avec le nom et la date du fichier
ActiveSheet.Range("A1:N34").ExportAsFixedFormat Type:=xlTypePDF, Filename:=fichier, _
Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=False, OpenAfterPublish:=False 'on exporte au format PDF
Dim messageHTML
On Error GoTo errorHandler
'on crée le fichier PDF dans le même dossier que le fichier source
Sheets("feuillmatch").ExportAsFixedFormat Type:=xlTypexslm, Filename:= _
ActiveWorkbook.Path & "\" & "feuillmatch.PDF" ' à changer 'Toute la Feuille
piece_bis = ActiveWorkbook.Path & "\" & "feuillmatch.PDF" ' à modifier
Range("A14:A34").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 13434879
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With Selection.Font
.Color = -3342337
.TintAndShade = 0
End With
Sheets("Convocs").Range("$A$1:$F$34").ExportAsFixedFormat Type:=xlTypexslm, Filename:= _
ActiveWorkbook.Path & "\" & "Convocs.PDF" ' Ligne Modifiée , Modifier convocs
Set objMessage = CreateObject("CDO.Message")
objMessage.Subject = "Convocations U13" 'A modifier
objMessage.From = "vv@free.fr" 'adresse mail de l'expéditeur n'est pas obligatoire
objMessage.To = "vv@free.fr" 'Email du destinataire doit-être correct ici mettre les adresse mail séparer par des ;
objMessage.CC = Range("b40") 'a modifier
objMessage.BCC = "" 'Email copie cachée idem a from
objMessage.TextBody = Range("A101") & Range("A102") & Range("A103") & vbCrLf & vbCrLf & Range("") & vbCrLf & vbCrLf & Range("A105") ' A modifier
piece_jointe = ActiveWorkbook.Path & "\" & "convocs.PDF" ' à modifier
messageHTML = "Ceci est un message en HTML"
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" 'mettre adresse serveur type A modifier
objMessage.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
objMessage.Configuration.Fields.Update
objMessage.AddAttachment (piece_jointe) 'On ajoute la piéce jointe, il est possible d'envoyer plusieurs pièces
objMessage.AddAttachment (piece_bis) 'dans ce cas on ajoute un objMessage.AddAttachement () par pièce
objMessage.Send
MsgBox "Le mail à bien été envoyé à """
'la feuille PDF créée est supprimée après l'envoi
Range("A15,A18,A20,A22,A24,A26,A28,A30,A32").Select
Range("A32").Activate
With Selection.Font
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
End With
Range("A16,A19").Select
Range("A19").Activate
With Selection.Font
.Color = -16776961
.TintAndShade = 0
End With
Range("A21,A23,A25,A27,A29,A31,A33").Select
Range("A33").Activate
With Selection.Font
.ColorIndex = xlAutomatic
.TintAndShade = 0
End With
Range("A15").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 15269765
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("A18,A20,A22,A24,A26,A28,A30,A32").Select
Range("A32").Activate
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 16769217
.TintAndShade = 0
.PatternTintAndShade = 0
End With
ActiveSheet.Protect Password:="alcoataudon" 'on met le mot de passe
Kill ActiveWorkbook.Path & "\" & "Convocs.PDF" 'à modifier
'si erreur on sort de la procédure
Exit Sub
errorHandler:
'description de l'erreur survenue
MsgBox Err.Description
ActiveWorkbook.Save 'on sauvegarde
Application.ScreenUpdating = True
End Sub |
