Bonjour
j'utilise ce code (adapté du calendrier outlook) pour rechercher un mail selon divers critères, le but étant de le déplacer sur mon disque dur après divers traitements.
tout fonction, sauf la copie sur le dd.
Access me dit, à la ligne SAVEAS, que je ne dispose pas des autorisations nécessaires ...
Que dois-je faire ?
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 Private Sub Commande0_Click() Dim myOlApp As Outlook.Application Dim myNameSpace As Outlook.NameSpace Dim myAppointments As Outlook.Items Dim currentAppointment As Outlook.MailItem Set myOlApp = CreateObject("Outlook.Application") Set myNameSpace = myOlApp.GetNamespace("MAPI") Dim msg As String Dim db As DAO.Database Dim sql As String Dim sql2 As String Set myAppointments = myNameSpace.GetDefaultFolder(olFolderInbox).Items myAppointments.Sort "[receivedtime]", True Set currentAppointment = myAppointments.Find("[ReceivedTime] >= '" & Format(Me.date, "dd/mm/yyyy hh:nn") & "' and [ReceivedTime] <= '" & Format(DateAdd("n", 1, date), "dd/mm/yyyy hh:nn") & "'") While TypeName(currentAppointment) <> "Nothing" If currentAppointment.EntryID = Me.Texte7 Then sql = "update référenceintervenant2 set [categorie]='rouge' where entryid ='" & Me.Texte7 & "'" DoCmd.RunSQL sql currentAppointment.Subject = currentAppointment.Subject & " Paf déplacé" currentAppointment.Categories = "rouge" currentAppointment.Save currentAppointment.SaveAs "c:\test.msg", olMSG End If 'Recherche s'il existe d'autres rdv correspondant aux critères Set currentAppointment = myAppointments.FindNext Wend MsgBox "fin" End Sub
Partager