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