VBA - Extraction calendrier

[LaughatLife]

Bonsoir à toutes et tous,
J'essaye depuis un moment d'extraire le contenu des calendriers de collaborateurs pour l'avoir sous excel afin de faire du traitement d'information.
Pour ce l'extraction est fait en s'appuyant sur les catégories de Outlook. Sans vouloir réaliser une usine à gaz ni une application, j'aimerai pouvoir lancer un VBA qui me permette de définir les plages d'extraction (date), les personnes et les catégories.

Voici le code que j'utilise :

Sub Liste_rdv()

Dim olApp As Object
Dim olNs As Object
On Error Resume Next

'OUVERTURE D'OUTLOOK
Set olApp = GetObject(, "Outlook.Application")
If Err.Number = 429 Then
Set olApp = CreateObject("Outlook.application")
End If
On Error GoTo 0
Set olNs = olApp.GetNamespace("MAPI")

'Définition des consultants
Const nb_consultants = 5
Dim tab_consultant(nb_consultants)

'Remplir le tableau avec les consultants et l'orthographe exacte qui apparait dans Outlook
tab_consultant(1) = "guillaume"
tab_consultant(2) = "antoine"
tab_consultant(3) = "jeancharles"
tab_consultant(4) = "raymond"
tab_consultant(5) = "thomas"


On Error Resume Next
Sheets("PLANNING").Delete
On Error GoTo 0

Set feuille = Sheets.Add
feuille.Select
feuille.Name = "PLANNING"
i = 1
Range("A1").Select
ActiveSheet.Cells(i, 1).Value = "Consultant"
ActiveSheet.Cells(i, 2).Value = "Début"
ActiveSheet.Cells(i, 3).Value = "Jour Début"
ActiveSheet.Cells(i, 4).Value = "Année"
ActiveSheet.Cells(i, 5).Value = "Mois"
ActiveSheet.Cells(i, 6).Value = "Semaine"
ActiveSheet.Cells(i, 7).Value = "Fin"
ActiveSheet.Cells(i, 8).Value = "Jour Fin"
ActiveSheet.Cells(i, 9).Value = "Durée m"
ActiveSheet.Cells(i, 10).Value = "Durée h"
ActiveSheet.Cells(i, 11).Value = "Catégorie"
ActiveSheet.Cells(i, 12).Value = "Sujet"
ActiveSheet.Cells(i, 13).Value = "Disponbilité"
ActiveSheet.Cells(i, 14).Value = "Sociétés"
ActiveSheet.Cells(i, 15).Value = "Lieu"
ActiveSheet.Cells(i, 16).Value = "Organisateur"
ActiveSheet.Cells(i, 17).Value = "Corps"
TRAITEMENT.Show 0

For j = 1 To nb_consultants
TRAITEMENT.Tot_consultant.Caption = Int(nb_consultants)
TRAITEMENT.Num_consultant.Caption = j
TRAITEMENT.Nom_consultant.Caption = tab_consultant(j)

Set consultant = olNs.CreateRecipient(tab_consultant(j))
consultant.Resolve

If consultant.Resolved Then
On Error GoTo auth_ko
Set folder_appoint = olNs.GetSharedDefaultFolder(consultant, 9)

'POUR TOUS LES RENDEZ-VOUS DANS LE REPERTOIRE CALENDRIER
TRAITEMENT.tot_rdv = folder_appoint.Items.Count
TRAITEMENT.num_rdv = 0

For Each rdv In folder_appoint.Items

TRAITEMENT.num_rdv = TRAITEMENT.num_rdv + 1
TRAITEMENT.Repaint

'On ne prend que les enregistrements dans les catégories reporting
Select Case rdv.Categories
Case "RDV", "AGENCE", "CONGES", "FORMATION", "MALADE"

i = i + 1
'ON AJOUTE UNE LIGNE
ActiveSheet.Cells(i, 1).Value = tab_consultant(j)
ActiveSheet.Cells(i, 2).Value = rdv.Start
ActiveSheet.Cells(i, 3) = "=DATE(YEAR(RC[-1]),MONTH(RC[-1]),DAY(RC[-1]))"
ActiveSheet.Cells(i, 4).FormulaR1C1 = "=YEAR(RC[-1])"
ActiveSheet.Cells(i, 5).FormulaR1C1 = "=MONTH(RC[-2])"
ActiveSheet.Cells(i, 6).FormulaR1C1 = "=NO.SEMAINE(RC[-3],2)"
ActiveSheet.Cells(i, 7).Value = rdv.End
ActiveSheet.Cells(i, 8) = "=DATE(YEAR(RC[-1]),MONTH(RC[-1]),DAY(RC[-1]))"
ActiveSheet.Cells(i, 9).Value = rdv.Duration
ActiveSheet.Cells(i, 10).FormulaR1C1 = "=RC[-1]/60"
ActiveSheet.Cells(i, 11).Value = rdv.Categories
ActiveSheet.Cells(i, 12).Value = rdv.Subject
ActiveSheet.Cells(i, 13).Value = rdv.BusyStatus
ActiveSheet.Cells(i, 14).Value = rdv.Companies
ActiveSheet.Cells(i, 15).Value = rdv.Location
ActiveSheet.Cells(i, 16).Value = rdv.Organizer
ActiveSheet.Cells(i, 17).Value = rdv.Body

End Select

Next

'Tri sur la date de début
Range("A:J").Sort Key1:=Range("B2"), Order1:=xlAscending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
'Changement de format
Columns("B:B").Select
Selection.NumberFormat = "dd/mm/yy hh:mm"
Columns("H:H").Select
Selection.NumberFormat = "dd/mm/yy hh:mm"

Range("A1").Select
'Fin si consultant trouvé
auth_ko:
Resume sortie
sortie:
End If
'Consultant suivant
Next j
TRAITEMENT.Hide
End Sub

Dans un premier temps je cherche à optimiser le code puis à déveloper l'interface.

Quelqu'un pourrait il me donner un coup de main.

Un grand merci d'avance à tous

 

[Compte Supprimé 979]

Re : VBA - Extraction calendrier

Salut Laughatlife, bienvenue sur le forum

Dans ton code tu ne déclare nulle part : olApp

Pourrais-tu ré-éditer ton message et mettre le code en entier !?

A+

 

[LaughatLife]

Re : VBA - Extraction calendrier

Je viens d'effectuer les modifications sur le post initial pour inclure les déclarations.

 

[LaughatLife]

Re : VBA - Extraction calendrier

Bonjour à tous,

Personne ne peux me donner un coup de main ?

HELP ME PLEASE