Discussion :

[oceane57]

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
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
'Déclarations des variables et objets
Public objApply As Outlook.Application
Public objNameSpace As Outlook.NameSpace
Public objFolder As Outlook.MAPIFolder
 
'flux texte qui sera recopié dans le fichier excel
'correspond à une ligne dans excel
Public strStream As String
 
'fichier en sortie, lisible par excel (séparation par point virgule)
Public objFSO As New Scripting.FileSystemObject
Public fsoFichier As Scripting.TextStream
 
' objet dans le calendrier : rendez-vous ou réunion
Public objCalendrier As Outlook.AppointmentItem
 
'permet de récupérer les propriétés personnelles rajoutées dans le formulaire créé spécialement pour ce projet
Public unobjet As Outlook.UserProperty
Public uneActivite As Outlook.UserProperty
 
'entier pour "compter" les éléments dans le calendrier
Public intNbr As Integer
 
'plage à traiter
Public Datedebut As Variant
Public datefin As Variant
 
Public dateDEB As Date
Public dateFN As Date
 
Sub Export_CalendrierCSV()
'---------------------------------------------------------------------------------------
' Procédure : Export_CalendrierCSV
' Auteur    :
' Date      : 16/06/2009
' Détail    : Permet d'exporter le calendrier sous forme CSV (séparation avec des point virgule)
'---------------------------------------------------------------------------------------
'
 
' dates limites pour la reprise des données
Datedebut = InputBox(" DATE DE DEBUT ? ", _
    "date de début", DateAdd("m", -1, Date))
 
'contrôle de la saisie des dates (bon format et renseignée)
If Not (TestValidDate(Datedebut)) Then
    MsgBox "traitement non effectué, date invalide, veuillez recommencer"
    Exit Sub
Else
'    dateDEB = DateAdd("d", -1, Datedebut)
    dateDEB = Datedebut
End If
 
 
datefin = InputBox("DATE DE FIN ? ", _
    "date de fin", Date)
 
'contrôle de la saisie des dates (bon format et renseignée)
If Not (TestValidDate(datefin)) Then
    MsgBox "traitement non effectué, date invalide, veuillez recommencer"
    Exit Sub
Else
    dateFN = DateAdd("d", 1, datefin)
End If
 
 
 
'Instance et création du fichier texte
Set fsoFichier = objFSO.CreateTextFile("T:\SuiviActivite.csv", True)
 
' - Création des entêtes de colonnes.
strStream = "Ressource;Date;Duree;Sujet;Projet;activité projet;"
'Ecriture dans le fichier de l'entête
fsoFichier.WriteLine (strStream)
 
'Instance des objets Outlook
Set objApply = Outlook.Application
Set objNameSpace = objApply.GetNamespace("MAPI")
Set objFolder = objNameSpace.GetDefaultFolder(olFolderCalendar)
 
    Call TraitementRendezVousPlusPeriodiques
 
'Fermeture du fichier
fsoFichier.Close
'Message de fin d'export
MsgBox "Export terminé"
 
End Sub

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
Sub TraitementRendezVousPlusPeriodiques()
 
    Dim myAppointments As Outlook.Items
 
    Set myAppointments = objNameSpace.GetDefaultFolder(olFolderCalendar).Items
    myAppointments.Sort "[Start]"
    myAppointments.IncludeRecurrences = True
    Set objCalendrier = myAppointments.Find("[Start] >= """ & dateDEB & """ and [Start] < """ & dateFN & """")
 
'   on exclut les congés pour le rapport d'activités
'    If InStr(1, objCalendrier.Categories, "Congé", vbTextCompare) = 0 Then
 
    While TypeName(objCalendrier) <> "Nothing"
        'si ce n'est pas un rendez-vous privé, on continue la sélection
        If objCalendrier.Sensitivity <> olPrivate Then
            Call ecr_fichier
        End If
        Set objCalendrier = myAppointments.FindNext
    Wend
 
End Sub

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
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
Sub ecr_fichier()
    'récupération du propriétaire du calendrier
     strStream = objNameSpace.CurrentUser & ";"
        If objCalendrier.AllDayEvent = True Then
            'si sur 1 journée
            strStream = strStream & Format(objCalendrier.Start, "dd/mm/yyyy") & ";" & 8 & ";"
 
        Else
    'pas sur 1 journée
            strStream = strStream & Format(objCalendrier.Start, "dd/mm/yyyy") & ";" _
                        & objCalendrier.Duration / 60 & ";"
        End If
 
 
        strStream = strStream & objCalendrier.Subject & ";"
 
        Set unobjet = objCalendrier.UserProperties.Find("identifiant projet")
        If TypeName(unobjet) <> "Nothing" Then
           If unobjet.Value <> "" Then
                strStream = strStream & unobjet.Value & ";"
                Set uneActivite = objCalendrier.UserProperties.Find("activite projet")
                If TypeName(uneActivite) <> "Nothing" Then
                      strStream = strStream & uneActivite.Value & ";"
                Else
                    strStream = strStream & ";"
                End If
            End If
        End If
 
 
        Set unobjet = objCalendrier.UserProperties.Find("identifiant application")
        If TypeName(unobjet) <> "Nothing" Then
            If unobjet.Value <> "" Then
                strStream = strStream & unobjet.Value & ";"
                Set uneActivite = objCalendrier.UserProperties.Find("activite application")
                If TypeName(uneActivite) <> "Nothing" Then
                      strStream = strStream & uneActivite.Value & ";"
                Else
                    strStream = strStream & ";"
                End If
            End If
        End If
 
        Set unobjet = objCalendrier.UserProperties.Find("activite cyclique")
        If TypeName(unobjet) <> "Nothing" Then
            If unobjet.Value <> "" Then
                strStream = strStream & ";" & unobjet.Value & ";"
'        Else
'            strStream = strStream & ";;"
            End If
        End If
 
 
        'Ecriture dans le fichier
        fsoFichier.WriteLine (strStream)
        Set unobjet = Nothing
        Set uneActivite = Nothing
End Sub

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
Function TestValidDate(ByVal DDay As Variant) As Boolean
If DDay <> "" Then
        If Not IsDate(DDay) Then
            MsgBox "La date saisie n'est pas valide"
            TestValidDate = False
        Else
            TestValidDate = True
        End If
Else
    TestValidDate = False
End If
End Function

[oceane57]

Le formulaire personnalisé se crée, à partir du calendrier, avec
outils>formulaires>Choisir un formulaire
en prendre un dans la bibliothèque standard
le modifier, puis le PUBLIER (dans dossier Outlook par exemple)

pour le mettre par défaut
aller sur le calendrier à gauche de l'écran, clic droit, propriétés,
et lors de la publicationdans ce dossier, utiliser , choisir le formulaire que vous avez créé.
s'il n'apparait pas ici, allez dans l'onglet formulaire des propriétés du calendrier

[aalex_38]

Bonjour,


Merci pour cette contribution très intéressante, pour exporter ses données calendrier. J'ai pu tout de suite vérifier et corriger.

2 remarques :
- Il ne faut pas oublier de cocher la référence : Microsoft Scripting Runtime
- Il faut adapter le code pour indiquer son propre chemin pour le fichier export :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
'Instance et création du fichier texte
Dim Cible As String
Cible = "mettre ici le chemin du fichier export"
If Right(Cible, 1) <> "\" Then: Cible = Cible & "\":
 
Set fsoFichier = objFSO.CreateTextFile(Cible & "SuiviActivite-" & Year(Now) & Format(Month(Now), "#00") & Format(Day(Now), "#00") & "-" & Format(DatePart("h", Now), "#00") & Format(DatePart("n", Now), "#00") & ".csv", True)

[PHILJEAN]

Mrci pour ce code qui me sert énormément!