Bonjour,
Voici une macro qui récupère les données de 2 fichiers, sauvegarde le classeur.MOD en ajoutant la date du jour.
Si je ne mets pas la date, le classeur est bien envoyé à tous les destinataires.
Si j'ajoute la date du jour, la macro ne renvoie pas de message d'erreur mais n'envoie pas le classeur.
Pouvez-vous m'aider ?
D'avance merci

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
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
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
Private Sub WorkBook_Open()
' StockCrelogRCC Macro
Workbooks.Open Filename:= _
        "G:\CONTRATS1.xls"
    Range("A1:K20000").Select
    Selection.Copy
    Windows("CONTRATS-MOD.xls").Activate
    Sheets("RCC").Select
    Range("A1:K20000").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
 
' RCT Macro
Workbooks.Open Filename:= _
        "G:\CONTRATS2.xls"
    Range("A1:K20000").Select
    Selection.Copy
    Windows("CONTRATS-MOD.xls").Activate
    Sheets("RCT").Select
    Range("A1:K20000").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
 
Workbooks.Open Filename:= _
        "G:\CONTRATS1.xls"
    'Windows("CONTRATS1.xls").Activate
    Range("A1").Select
    ActiveWorkbook.Save
    ActiveWorkbook.Close
 
Workbooks.Open Filename:= _
        "G:\CONTRATS2.xls"
    'Windows("CONTRATS2.xls").Activate
    Range("A1").Select
    ActiveWorkbook.Save
    ActiveWorkbook.Close
 
    'Workbooks.Open Filename:= _
    '    "G:\CONTRATS-MOD.xls"
    Windows("CONTRATS-MOD.xls").Activate
    Sheets("RCC").Select
    Range("A1").Select
    Sheets("RCT").Select
    Range("A1").Select
    ActiveWorkbook.Save
 
'Sauvegarde du fichier
    Application.DisplayAlerts = False
    NomFichier = "CONTRATS-" & Format(Now, "dd-mm-yyyy"".xls")
    'NomFichier2 = "CONTRATS.xls"
    ChDir "G:\"
    ActiveWorkbook.SaveAs Filename:=NomFichier, CreateBackup:=False
 
'Sub EnvoiLotus()
   Workbooks.Open Filename:= _
        "G:\CONTRATS-*.xls"
 
'Set up the objects required for Automation into lotus notes
Dim Maildb As Object 'The mail database
Dim UserName As String 'The current users notes name
Dim MailDbName As String 'THe current users notes mail database name
Dim MailDoc As Object 'The mail document itself
Dim AttachME As Object    'The attachment richtextfile object
Dim Session As Object 'The notes session
Dim EmbedObj As Object 'The embedded object (Attachment)
 
Set Session = CreateObject("Notes.NotesSession")
 
'Get the sessions username and then calculate the mail file name
'You may or may not need this as for MailDBname with some systems you
'can pass an empty string
UserName = Session.UserName
MailDbName = Left$(UserName, 1) & Right$(UserName, (Len(UserName) - InStr(1, UserName, " "))) & ".nsf"
 
'Open the mail database in notes
Set Maildb = Session.GETDATABASE("", MailDbName)
If Maildb.IsOpen = True Then
 
'Already open for mail
Else
Maildb.OPENMAIL
End If
 
'Set up the new mail document
Set MailDoc = Maildb.CREATEDOCUMENT
MailDoc.Form = "Memo"
'Pour ouvrir un modèle
MailStationeryName = "Crélog lundi*: Contrats"    'MailStationeryName = "Nom du modèle"
MailDoc.sendto = Split(Worksheets("Destinataires").Cells(2, 2).Value, ",")
MailDoc.CopyTo = Split(Worksheets("Destinataires").Cells(4, 2).Value, ",")
MailDoc.BlindCopyTo = ""
MailDoc.Subject = "Crélog lundi*: Contrats"
 
 
Set objNotesField = MailDoc.CREATERICHTEXTITEM("Body")
With objNotesField
    .AppendText "Bonjour,"
    .AddNewLine 2
    .AppendText "Voici le fichier hebdo Contrats" 'tu peux ajouter des lignes
    .AddNewLine 2
    .AppendText "Cordialement"
    .AddNewLine 4
    .AppendText "L'équipe"
    .AddNewLine 7
    .AppendText "Envoi automatique"
    .AddNewLine 3
End With
 
MailDoc.SAVEMESSAGEONSEND = SaveIt
 
'Set up the embedded object and attachment and attach it
Attachment1 = "G:\CONTRATS-*.xls"
'Attachment2 = ""
'Attachment3 = ""
 
Set AttachME = MailDoc.CREATERICHTEXTITEM("Attachment1")
Set EmbedObj = AttachME.EMBEDOBJECT(1454, "", Attachment1, "Attachment1")
MailDoc.CREATERICHTEXTITEM (Attachment1)
'Set AttachME = MailDoc.CREATERICHTEXTITEM("Attachment2")
'Set EmbedObj = AttachME.EMBEDOBJECT(1454, "", Attachment2, "Attachment2")
'MailDoc.CREATERICHTEXTITEM (Attachment2)
'Set AttachME = MailDoc.CREATERICHTEXTITEM("Attachment3")
'Set EmbedObj = AttachME.EMBEDOBJECT(1454, "", Attachment3, "Attachment3")
'MailDoc.CREATERICHTEXTITEM (Attachment3)
 
'Send the document
MailDoc.PostedDate = Now() 'Gets the mail to appear in the sent items folder
MailDoc.SEND 0, Recipient
 
'Clean Up
Set Maildb = Nothing
Set MailDoc = Nothing
Set AttachME = Nothing
Set Session = Nothing
Set EmbedObj = Nothing
 
    'ActiveWorkbook.Save
    'ActiveWorkbook.Close
 
End Sub