Besoin d'aide sur petites imperfections d'une macro

**Adeline8** · 12/06/2017, 11h28

bonjour,

j'ai "bidouillé" une macro grâce à plusieurs codes trouvés sur divers forums, et sa fonction principale est remplie puisqu'elle créé bien des RDV dans un calendrier partagé depuis un tableau excel.
Le plus gros problème, c'est que quand je lance cette macro, ça m'ouvre à nouveau outlook (déjà ouvert sur mon ordinateur), et dans cette fenêtre, seul mon calendrier perso est affiché, alors que le RDV s'enregistre bien dans le calendrier partagé.
J'aimerais que ça n'ouvre plus cette fenêtre outlook quand je lance la macro, quelqu'un peut-il m'aider svp ?
(précision : je n'y connais pas grand chose, je n'arrive pas à comprendre à quoi correspondent les codes. il y a aura donc certainement des choses en "trop" dans ma macro)

Merci par avance à ceux qui m'aideront

voila le code que j'utilise :

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
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
 
Sub essai_macro_5()
Dim DLig As Long, Lig As Long
Dim DateRdv As Date, FlgRdv As Boolean
Dim OutObj As Outlook.Application
Dim OutAppt As Outlook.AppointmentItem
Dim MyCalendar As Outlook.Items
Dim NS As Outlook.Namespace
Dim objOwner As Outlook.Recipient
 
'Dim OL As Outlook.Application
Dim olns As Outlook.Namespace
Dim myRecipient As Outlook.Recipient
Dim myFolder As Outlook.Folder
Dim objExpCal As Outlook.Explorer
Dim objNavMod As Outlook.CalendarModule
Dim objNavGroup As Outlook.NavigationGroup
Dim objNavFolder As Outlook.NavigationFolder
Dim objAppt As AppointmentItem
 
Dim OL As Object
Dim OLmail As Object
 
 
Set OLk_Appli = CreateObject("Outlook.Application")
 
If OLk_Appli.Explorers.Count > 0 Then
'Ok outlook ouvert
Else
'mettre le bon chemin outlook
OLk_OK = Shell("C:\Program Files (x86)\Microsoft Office\Office15\outlook.exe", vbHide)
End If
 
Set OL = New Outlook.Application
Set olns = Outlook.Application.Session
Set objExpCal = olns.GetDefaultFolder(olFolderCalendar).GetExplorer
Set objNavMod = objExpCal.NavigationPane.Modules.GetNavigationModule(olModuleCalendar)
Set objNavGroup = objNavMod.NavigationGroups.GetDefaultNavigationGroup(olPeopleFoldersGroup)
Set objAppt = Outlook.Application.CreateItem(olAppointmentItem)
If olns.DefaultStore.DisplayName = "richard.XXX@XXXXXX.com" Then
'cas où le propriétaire du calendrier partagé fait l'opération
Set myFolder = olns.GetDefaultFolder(olFolderCalendar)
Set Mysubfolder = myFolder.Folders("SRY Tomato Planning").Items
Else
'cas où un autre utilisateur ayant les droits d'éditeur fait l'opération
Set myRecipient = olns.CreateRecipient("richard.XXX@XXXXXX.com")
myRecipient.Resolve
If myRecipient.Resolved Then
Set Mysubfolder = objNavGroup.NavigationFolders("SRY Tomato Planning").Folder.Items
End If
End If
 
' Avec la feuille
With Sheets("Feuil1")
DLig = .Range("A" & Rows.Count).End(xlUp).Row
' Pour chaque ligne
For Lig = 2 To DLig
' Si une date existe
If .Range("D" & Lig) <> "" Then
' Si un RDV n'a pas déjà été créé
If .Range("K" & Lig) <> "" Then
' Si le commentaire a changé
If .Range("K" & Lig).Comment.Text <> .Range("H" & Lig).Value Then
FlgRdv = False
Else
' Sinon le commentaire n'a pas changé = pas de RDV
FlgRdv = False
End If
Else
' Sinon, pas de RDV déjà créé
FlgRdv = True
End If
Else
' Sinon, pas de date d'évènement
FlgRdv = False
End If
' Si le FLAG est à vrai on créé le RDV
If FlgRdv Then
DateRdv = Range("D" & Lig)
 
'Set OutAppt = MyCalendar.Add
'With OutAppt
Set OutAppt = Mysubfolder.Add
With OutAppt
.MeetingStatus = olMeeting
.Subject = Range("E" & Lig) & " - " & Range("F" & Lig) & " - " & Range("B" & Lig) & " - " & Range("D" & Lig)
.Start = Range("D" & Lig) & " 06:00"
.Duration = 60
.ReminderSet = True
.ReminderMinutesBeforeStart = 60 * 24 * Range("I" & Lig)
.Categories = Range("C" & Lig)
.Location = Range("G" & Lig)
.Body = Range("H" & Lig)
.RequiredAttendees = Range("J" & Lig)
.Send
.Save
End With
' Créer le commentaire et inscrire Oui
On Error Resume Next
.Range("K" & Lig).Comment.Delete
.Range("K" & Lig).AddComment
.Range("K" & Lig).Comment.Text Text:=Range("H" & Lig).Value '& Chr(10) & Format(Date, "dd mmmm yyyy")
.Range("K" & Lig) = "Oui"
On Error GoTo 0
End If
Next Lig
End With
Set OutAppt = Nothing
 
 
 
 
End Sub

**joe.levrai** · 12/06/2017, 11h31

Bonjour,

il faut tester si une instance existe (et la récupérer le cas échéant), sinon on la crée

ma procédure générique que j'utilise dans tout utilitaire excel qui pilote outlook

Code :

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

1
2
3
4
5
6
7
8
Dim OlApp As Object ' outlook.application
Dim OlNmSpace As Object ' outlook.namespace
 
Sub InitialisationOutlook()
    On Error Resume Next: Set OlApp = GetObject(, "Outlook.Application"): On Error GoTo 0
    If OlApp Is Nothing Then Set OlApp = CreateObject("Outlook.Application")
    Set OlNmSpace = OlApp.GetNamespace("MAPI")
End Sub

**Adeline8** · 12/06/2017, 11h40

Bonjour joe.levrai,

merci de votre réponse.
à quel endroit dans mon code faut-il que j'insère votre code ? dois-je faire des adaptations à mon code ?
désolée je suis vraiment débutante

**joe.levrai** · 12/06/2017, 11h44

tu supprimes la partie de ta procédure située entre la ligne 24 et 35 (incluse)

tu colles les lignes de code que je t'ai proposé à la place (sans les deux déclarations de variables au dessus de la procédure)
tu renommes mes variables (OlApp devient OutObj et OlNmSpace devient OlNs)

c'est la façon brute, mais la façon la plus simple pour toi.

**Adeline8** · 12/06/2017, 14h09

j'ai fait tout ce que tu m'as dit, mais ça ne marche pas. enfin, la macro fonctionne toujours sans planter, mais le problème n'est pas résolu.

voilà ce que j'ai fait :

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
 Dim OL As Object
 Dim OLmail As Object
 
 
 On Error Resume Next: Set OutObj = GetObject(, "Outlook.Application"): On Error GoTo 0
    If OutObj Is Nothing Then Set OutObj = CreateObject("Outlook.Application")
    Set olns = OutObj.GetNamespace("MAPI")
 
Set objExpCal = olns.GetDefaultFolder(olFolderCalendar).GetExplorer
Set objNavMod = objExpCal.NavigationPane.Modules.GetNavigationModule(olModuleCalendar)
Set objNavGroup = objNavMod.NavigationGroups.GetDefaultNavigationGroup(olPeopleFoldersGroup)
Set objAppt = Outlook.Application.CreateItem(olAppointmentItem)

**joe.levrai** · 12/06/2017, 14h17

Oh la vilaine ligne 12 que je n'avais pas remarqué

Remplace "Outlook.Application" par ta variable représentant l'instance outlook que tu as récupéré (OutObj)

et si ça ne fonctionne toujours pas, remet ton code mais en entier, là on a juste une parte de ta nouvelle procédure

**Adeline8** · 12/06/2017, 14h24

j'ai essayé mais ça n'a pas marché.
voici donc mon code en entier :

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
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
Sub essai_macro_aide_forum()
      Dim DLig As Long, Lig As Long
      Dim DateRdv As Date, FlgRdv As Boolean
      Dim OutObj As Outlook.Application
      Dim OutAppt As Outlook.AppointmentItem
      Dim MyCalendar As Outlook.Items
      Dim NS As Outlook.Namespace
Dim objOwner As Outlook.Recipient
 
'Dim OL As Outlook.Application
Dim olns As Outlook.Namespace
Dim myRecipient As Outlook.Recipient
Dim myFolder As Outlook.Folder
Dim objExpCal As Outlook.Explorer
Dim objNavMod As Outlook.CalendarModule
Dim objNavGroup As Outlook.NavigationGroup
Dim objNavFolder As Outlook.NavigationFolder
Dim objAppt As AppointmentItem
 
 Dim OL As Object
 Dim OLmail As Object
 
 
 On Error Resume Next: Set OutObj = GetObject(, "Outlook.Application"): On Error GoTo 0
    If OutObj Is Nothing Then Set OutObj = CreateObject("Outlook.Application")
    Set olns = OutObj.GetNamespace("MAPI")
 
Set objExpCal = olns.GetDefaultFolder(olFolderCalendar).GetExplorer
Set objNavMod = objExpCal.NavigationPane.Modules.GetNavigationModule(olModuleCalendar)
Set objNavGroup = objNavMod.NavigationGroups.GetDefaultNavigationGroup(olPeopleFoldersGroup)
Set objAppt = OutObj.Application.CreateItem(olAppointmentItem)
If olns.DefaultStore.DisplayName = "richard.xxxxx@xxxxxx.com" Then
'cas où le propriétaire du calendrier partagé fait l'opération
    Set myFolder = olns.GetDefaultFolder(olFolderCalendar)
    Set Mysubfolder = myFolder.Folders("SRY Tomato Planning").Items
Else
'cas où un autre utilisateur ayant les droits d'éditeur fait l'opération
   Set myRecipient = olns.CreateRecipient("richard.xxxxx@xxxxxx.com")
       myRecipient.Resolve
    If myRecipient.Resolved Then
       Set Mysubfolder = objNavGroup.NavigationFolders("SRY Tomato Planning").Folder.Items
    End If
End If
 
         ' Avec la feuille
     With Sheets("Feuil1")
        DLig = .Range("A" & Rows.Count).End(xlUp).Row
        ' Pour chaque ligne
       For Lig = 2 To DLig
          ' Si une date existe
         If .Range("D" & Lig) <> "" Then
            ' Si un RDV n'a pas déjà été créé
           If .Range("K" & Lig) <> "" Then
           ' Si le commentaire a changé
          If .Range("K" & Lig).Comment.Text <> .Range("H" & Lig).Value Then
                        FlgRdv = False
                        Else
                   ' Sinon le commentaire n'a pas changé = pas de RDV
            FlgRdv = False
          End If
        Else
              ' Sinon, pas de RDV déjà créé
             FlgRdv = True
            End If
          Else
            ' Sinon, pas de date d'évènement
           FlgRdv = False
          End If
          ' Si le FLAG est à vrai on créé le RDV
         If FlgRdv Then
            DateRdv = Range("D" & Lig)
 
            'Set OutAppt = MyCalendar.Add
            'With OutAppt
            Set OutAppt = Mysubfolder.Add
            With OutAppt
             .MeetingStatus = olMeeting
             .Subject = Range("E" & Lig) & " - " & Range("F" & Lig) & " - " & Range("B" & Lig) & " - " & Range("D" & Lig)
             .Start = Range("D" & Lig) & " 06:00"
             .Duration = 60
             .ReminderSet = True
             .ReminderMinutesBeforeStart = 60 * 24 * Range("I" & Lig)
             .Categories = Range("C" & Lig)
            .Location = Range("G" & Lig)
            .Body = Range("H" & Lig)
            .RequiredAttendees = Range("J" & Lig)
            .Send
            .Save
            End With
             ' Créer le commentaire et inscrire Oui
           On Error Resume Next
            .Range("K" & Lig).Comment.Delete
            .Range("K" & Lig).AddComment
            .Range("K" & Lig).Comment.Text Text:=Range("H" & Lig).Value '& Chr(10) & Format(Date, "dd mmmm yyyy")
            .Range("K" & Lig) = "Oui"
            On Error GoTo 0
          End If
 
        Next Lig
 
      End With
      Set OutAppt = Nothing
 
 
 
 
    End Sub

**joe.levrai** · 12/06/2017, 14h35

En testant en pas à pas ta procédure, deux points de contrôles pour trouver le souci :

1) vérifie que quand la procédure passe sur la ligne 25, OutObj vaut bien quelque chose (ton instance outlook déjà ouverte) et qu'il ne passe pas dans la partie Then Set OutObj = CreateObject......

2) si ça se passe bien à la ligne 25, regarde sur quelle ligne de code VBA ouvre une nouvelle instance

fait un peu de ménage dans tes déclarations de variable, il y a des redondances (deux variables NameSpace dont une seule utilisée par exemple)
et indente correctement ton code, il est en l'état compliqué à appréhender dans sa structure logique

**Adeline8** · 12/06/2017, 14h43

alors, la ligne 25 passe bien, c'est sur la ligne de code 29 que VBA ouvre une nouvelle instance :

Code :

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

Set objNavMod = objExpCal.NavigationPane.Modules.GetNavigationModule(olModuleCalendar)

je vais essayer de faire le ménage dans les déclarations de variables !

Par contre pour l'indentation, c'est au delà de mes capacités.. :/

**Adeline8** · 13/06/2017, 11h14

Bonjour,

voilà, j'ai indenté correctement (à priori) mon code, merci internet !!

voilà ce que ça donne :

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
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
Sub essai_macro_aide_forum()
    Dim DLig As Long, Lig As Long
    Dim DateRdv As Date, FlgRdv As Boolean
    Dim OutObj As Outlook.Application
    Dim OutAppt As Outlook.AppointmentItem
    Dim MyCalendar As Outlook.Items
    Dim NS As Outlook.Namespace
    Dim objOwner As Outlook.Recipient
 
    Dim myRecipient As Outlook.Recipient
    Dim myFolder As Outlook.Folder
    Dim objExpCal As Outlook.Explorer
    Dim objNavMod As Outlook.CalendarModule
    Dim objNavGroup As Outlook.NavigationGroup
    Dim objNavFolder As Outlook.NavigationFolder
    Dim objAppt As AppointmentItem
 
    Dim OL As Object
    Dim OLmail As Object
 
 
    On Error Resume Next: Set OutObj = GetObject(, "Outlook.Application"): On Error GoTo 0
    If OutObj Is Nothing Then Set OutObj = CreateObject("Outlook.Application")
    Set olns = OutObj.GetNamespace("MAPI")
 
    Set objExpCal = olns.GetDefaultFolder(olFolderCalendar).GetExplorer
    Set objNavMod = objExpCal.NavigationPane.Modules.GetNavigationModule(olModuleCalendar)
    Set objNavGroup = objNavMod.NavigationGroups.GetDefaultNavigationGroup(olPeopleFoldersGroup)
    Set objAppt = OutObj.Application.CreateItem(olAppointmentItem)
    If olns.DefaultStore.DisplayName = "richard.xxxxx@xxxxxx.com" Then
'cas où le propriétaire du calendrier partagé fait l'opération
        Set myFolder = olns.GetDefaultFolder(olFolderCalendar)
        Set Mysubfolder = myFolder.Folders("SRY Tomato Planning").Items
    Else
'cas où un autre utilisateur ayant les droits d'éditeur fait l'opération
        Set myRecipient = olns.CreateRecipient("richard.xxxxx@xxxxxx.com")
        myRecipient.Resolve
        If myRecipient.Resolved Then
            Set Mysubfolder = objNavGroup.NavigationFolders("SRY Tomato Planning").Folder.Items
        End If
    End If
 
' Avec la feuille
    With Sheets("Feuil1")
        DLig = .Range("A" & Rows.Count).End(xlUp).Row
' Pour chaque ligne
        For Lig = 2 To DLig
' Si une date existe
            If .Range("D" & Lig) <> "" Then
' Si un RDV n'a pas déjà été créé
                If .Range("K" & Lig) <> "" Then
' Si le commentaire a changé
                    If .Range("K" & Lig).Comment.Text <> .Range("H" & Lig).Value Then
                        FlgRdv = True
                    Else
' Sinon le commentaire n'a pas changé = pas de RDV
                        FlgRdv = False
                    End If
                Else
' Sinon, pas de RDV déjà créé
                    FlgRdv = True
                End If
            Else
' Sinon, pas de date d'évènement
                FlgRdv = False
            End If
' Si le FLAG est à vrai on créé le RDV
            If FlgRdv Then
                DateRdv = Range("D" & Lig)
 
'Set OutAppt = MyCalendar.Add
'With OutAppt
                Set OutAppt = Mysubfolder.Add
                With OutAppt
                    .MeetingStatus = olMeeting
                    .Subject = Range("E" & Lig) & " - " & Range("F" & Lig) & " - " & Range("B" & Lig) & " - " & Range("D" & Lig)
                    .Start = Range("D" & Lig) & " 06:00"
                    .Duration = 60
                    .ReminderSet = True
                    .ReminderMinutesBeforeStart = 60 * 24 * Range("I" & Lig)
                    .Categories = Range("C" & Lig)
                    .Location = Range("G" & Lig)
                    .Body = Range("H" & Lig)
                    .RequiredAttendees = Range("J" & Lig)
                    .Send
                    .Save
                End With
' Créer le commentaire et inscrire Oui
                On Error Resume Next
                .Range("K" & Lig).Comment.Delete
                .Range("K" & Lig).AddComment
                .Range("K" & Lig).Comment.Text Text:=Application.UserName & ", " & Now() & " : " & Chr(10) & Range("H" & Lig).Value 
                .Range("K" & Lig) = "Oui"
                On Error GoTo 0
            End If
 
        Next Lig
 
    End With
    Set OutAppt = Nothing
 
End Sub

J'ai toujours ce problème d'instance qui s'ouvre une deuxième fois alors qu'Outlook est déjà ouvert (ça se passe à la ligne 27 de ce code ci-dessus).

J'ai également un autre problème : la macro ne passe pas aux lignes suivantes, elle ne créé un RDV que pour la première ligne de mon tableau (celle en dessous des noms de colonnes, donc la ligne 2 comme spécifié dans ma macro). Pourtant j'ai l'impression que j'ai indiqué ce qu'il fallait pour aller à la ligne jusqu'à la fin du tableau ?

Merci encore pour votre aide !

EDIT de 11h50 !!
Je viens de "résoudre" mon second problème, en fait il n'y avait tout simplement rien d'écrit dans la colonne A pour la ligne suivante, donc forcément la macro ne comptait pas cette deuxième ligne ! Honte à moi :!

Donc toujours UN SEUL et même problème, l'ouverture d'une deuxième instance d'Outlook à chaque fois que je lance ma macro :/

**mjpmjp** · 16/06/2017, 10h44

bonjour,

Code :

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

1
2
 
 On Error Resume Next: Set OutObj = GetObject(, "Outlook.Application"): On Error GoTo 0

leve : "On Error Resume Next", qui peu masquer le problème
et déplace : "On Error GoTo 0" , avant "set"

pour débug...

@+JP

**Adeline8** · 16/06/2017, 10h49

Bonjour JP,

merci pour ta réponse mais malheureusement ça n'a rien changé... une autre instance d'outlook s'ouvre toujours :/

**mjpmjp** · 16/06/2017, 10h53

bonjour,

rectification!!!
leve aussi "On Error GoTo 0"

Code :

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

1
2
3
4
5
6
 
On Error Goto GestionErr
  Set OutObj = GetObject(, "Outlook.Application")
if not OutlockExist then 
  ... toute la procédure d'ouverture
end if

GestionErr

Code :

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

1
2
3
4
 
GestionErr:
OutlookExist=true
Resume Next

**mjpmjp** · 16/06/2017, 10h56

re,
attention, je confirme la modif

Code :

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

1
2
3
4
5
6
 
On Error Goto GestionErr
Set OutObj = GetObject(, "Outlook.Application")
if not OutlockExist then 
  ... toute la procédure d'ouverture
end if

et

Code :

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

1
2
3
4
5
 
Exit sub
GestionErr:
OutlookExist=true
Resume Next

@+JP

**joe.levrai** · 16/06/2017, 11h00

Bonjour,

le problème n'est pas cette procédure d'initialisation (que j'utilise depuis des années sans souci), puisque la seconde instance s'ouvre beaucoup plus tard, lorsqu'elle créer des objet pour parcourir la liste des calendriers.
étant donné que tu connais le nom du calendrier partagé, peux-être que la ligne 25 pourrait être modifiée pour cibler directement le calendrier ?
je n'en utilise pas pour ma part, c'est donc un peu compliqué de dépanner ce point précis (ligne 26 à 28 qui ne sont utilisée que sur la ligne 39)

Besoin d'aide sur petites imperfections d'une macro

Macros et VBA Excel

Discussions similaires

Partager

Partager