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
| Sub Add_Time_on_sent_Email()
'---------------------------------------------------------------------------------------
' Procedure :
' Author : OCTU
' Date : 16/06/2015
' Purpose :
'---------------------------------------------------------------------------------------
'
Dim oFolder As Outlook.Folder
Dim objNS As NameSpace
'Get a Folder object
Set objNS = Application.GetNamespace("MAPI")
Set oFolder = objNS.PickFolder
ProcessFolderTIME oFolder, True
MsgBox "terminé"
End Sub
Sub ProcessFolderTIME(StartFolder As Outlook.MAPIFolder, SubFolder As Boolean)
'---------------------------------------------------------------------------------------
' Procedure : ProcessFolderSize
' Author : OCTU
' Date : 16/06/2015
' Purpose : Fonction recursive pour obtenir la taille des Dossiers
'---------------------------------------------------------------------------------------
'
Dim objFolder As Outlook.MAPIFolder
Dim Filter As String
Dim oRow As Outlook.Row
Dim oTable As Outlook.table
Dim oFolderSize As Double
Dim item As MailItem
'Dim objItem As Object
On Error Resume Next
' process all the subfolders of this folder
For Each objFolder In StartFolder.folders
Call ProcessFolderSize(objFolder, SubFolder)
Next
' process all the items in this folder
For Each objitem In StartFolder.items
If obitem.Class = olMailItem Then
Set item = objitem
Call ItemsAdd_time(item)
End If
Next
Set objFolder = Nothing
End Sub
Private Sub ItemsAdd_time(item As MailItem)
'---------------------------------------------------------------------------------------
' Procedure : ItemsAdd_time
' Author : OCTU
' Date : 23/06/2015
' Purpose : ajout de propriétés sur les emails
'---------------------------------------------------------------------------------------
'
Dim Props As Outlook.UserProperties
Dim Prop As Outlook.UserProperty
Dim PropName As String
Dim Prop1 As Outlook.UserProperty
Dim PropName1 As String
PropName = "HeureEnvoi"
PropName1 = "NUIT"
Dim heure As Date
Dim Heuremax As Date
Dim HeureMin As Date
'###########ICI ON PARAMETRE LES HORAIRES DE FERMETURE##########################################
Heuremax = TimeSerial(17, 30, 0)
HeureMin = TimeSerial(9, 30, 0)
'###############################################################################################
heure = TimeSerial(Hour(item.SentOn), Minute(item.SentOn), Second(item.SentOn))
Set Props = item.UserProperties
Set Prop = Props.Find(PropName, True)
If Prop Is Nothing Then
Set Prop = Props.add(PropName, olDateTime, True)
End If
Prop.value = Format(item.SentOn, "hh:mm")
Set Prop1 = Props.Find(PropName1, True)
If Prop1 Is Nothing Then
Set Prop1 = Props.add(PropName1, olYesNo, True)
End If
Prop.value = Format(item.SentOn, "hh:mm")
If heure >= Heuremax Then
Prop1.value = True
ElseIf heure <= HeureMin Then
Prop1.value = True
Else
Prop1.value = False
End If
item.Save
End Sub |
Partager