Public num_id_arrivé As String, I As Integer
Sub MonAppliSousOutlook()
On Error Resume Next
'Déclaration des variables
Dim objXlApp As New Excel.Application 'Pour piloter l'application Excel
Dim objXlClas As Excel.Workbook 'Pour piloter le classeur Excel
Dim objInbox As Outlook.MAPIFolder
Dim objDestFolder As Outlook.MAPIFolder
Dim objNS As Outlook.NameSpace
Dim OLmail As Outlook.MailItem
Dim objItem As Outlook.Items
Dim nbJours As Long
Dim an As Integer
Dim I As Integer
Dim N As Long, a As Long, fr, v
'Instanciations
Set objXlApp = CreateObject("Excel.Application")
Set objNS = objOLApp.GetNamespace("MAPI")
Set objInbox = objNS.GetDefaultFolder(olFolderInbox) 'Boîte de réception
v = Split(objInbox.FolderPath, "\")
balOutlook = v(UBound(v) - 1) 'découpage chemin Boîte de réception
Set objInbox = objNS.Folders(balOutlook).Folders("Prise en charge demande")
an = Year(Date)
fr = Fer(an)
N = CLng(Date) + 1
'With objXlApp: .Visible = False: .ScreenUpdating = False: .DisplayAlerts = False: End With
'Ouverture du classeur
Set objXlClas = objXlApp.Workbooks.Open("C:\Copie de TestOutlook.xls")
For cpt = objInbox.Items.Count To 1 Step -1
'Ecrire une valeur dans Feuil1
With objXlClas.Worksheets(1) '1ère Feuille du classaur
a = .Range("A65536").End(-4162).row + 1
id_courrier_arr
.Range("A" & a).Value = num_id_arrivé
.Range("B" & a).Value = OLmail.CreationTime
.Range("C" & a).Value = Date
.Range("D" & a).Value = OLmail.SenderName
.Range("F" & a).Value = OLmail.Subject
N = AJouteJoursOuvrés(Date, 5, fr)
.Range("G" & a).Value = CDate(N)
N = AJouteJoursOuvrés(Date, 30, fr)
.Range("R" & a).Value = CDate(N)
End With
'Sauvegarde des modifications et fermeture du classeur
objInbox.Items(cpt).UnRead = False
objInbox.Items(cpt).Move objDestFolder
Next
'On ferme le fichier Excel
objXlClas.Close True
'On quitte Excel
objXlApp.Quit
'On libère les ressources
Set objXlClas = Nothing
Set objXlApp = Nothing
End Sub
Sub id_courrier_arr()
'composition du numéro d'identification du courrier
Dim an_arr As Integer
Dim incremen_arr As Variant
'recherche la derniére cellule non vide
Range("A65536").End(xlUp).Select
'déconposition de l'id arrivé
an_arr = Left(ActiveCell.Value, 4)
an = Year(Date)
If an_arr <> an Then
an_arr = Year(Date)
incremen_arr = "00"
Else
incremen_arr = Right(ActiveCell.Value, Len(ActiveCell.Value) - 5)
End If
incremen_arr = incremen_arr + 1
Do Until Len(incremen_arr) = 3
incremen_arr = "0" & incremen_arr
Loop
'incrémente la partie droite du num id
num_id_arrivé = an_arr & "-" & incremen_arr
End Sub
Function AJouteJoursOuvrés(ByVal d As Long, nbJours As Integer, Fer As Variant) As Long 'calcul ajout de jours ouvrés
Dim I As Integer, bAjoute As Boolean
For I = 1 To nbJours
d = d + 1
Do While Not IsError(Application.Match(CLng(d), Fer, 0)) Or Weekday(d) = 1 Or Weekday(d) = 7
d = d + 1
Loop
Next
AJouteJoursOuvrés = d
End Function
Function paq(a%, Optional T As Boolean = False) 'Calcul date de Pâques
Dim g&, c&, d&, h&, I&, r&
paq = ""
If a > 1582 Then
g = a Mod 19
c = Int(a / 100)
d = Int(c / 4)
h = (19 * g + c - d - Int((8 * c + 13) / 25) + 15) Mod 30
I = (Int(h / 28) * Int(29 / (h + 1)) * Int((21 - g) / 11) - 1) * Int(h / 28) + h
r = DateSerial(a - 400 * (a < 1900), 3, 28) + I - (2 + a + Int(a / 4) + I + d - c) Mod 7
paq = Day(r) & "/" & Month(r) & "/" & a
If a > 1899 Then paq = CDbl(CDate(paq))
End If
End Function
Function Fer(an%) 'liste de tous les jours fériés
Dim pq
pq = paq(an)
Fer = Array(CLng(DateSerial(an, 1, 1)), CLng(DateSerial(an, 5, 1)), CLng(DateSerial(an, 5, 8)), CLng(DateSerial(an, 7, 14)), CLng(DateSerial(an, 8, 15)), CLng(DateSerial(an, 11, 1)), CLng(DateSerial(an, 11, 11)), CLng(DateSerial(an, 12, 25)), pq + 1, pq + 39, pq + 50)
End Function
