Discussion :

[Boulatwo]

Bonjour,

-1- [Sous excel 2007] J'ai une base de donnée. (mon fichier excel est ouvert)

-2- [Sous excel 2007] Les données sont ensuite traitées sous forme de tableau croisé dynamique (mon fichier excel ouvert).

-3- [Sous excel 2007] ->[Sous Outlook 2007] Certaines infos du tableau croisé dynamique sont envoyés vers le "body" outlook.

-4- A ce moment mon mail est prêt à être envoyé (fichier excel et outlook) sont ouvert.

-5- Au moment de l'envoi du mail, j'aimerai copier dans mon fichier excel ouvert les infos (destinataire, objet, date,...)

********************

Alors même que mon fichier excel est ouvert, je n'arrive pas, depuis outlook à prendre la main dessus via (activeworkbook ou thisworkbook ou workbooks("fichier.xlsx"),....)

En revanche, si mon fichier est fermé, cela ne pose pas de problème en utilisant les méthodes du type:

Set XlApp = CreateObject("Excel.Application")
XlApp.Visible = True
XlApp.Workbooks.Open AdresseFichier
XlApp.Sheets("Mail").Range("B1").Value = "Première extraction"...

XlApp.Quit
Set XlApp = Nothing



Pouvez vous me dire comment manipuler ce fichier excel ?

J'ai cherché sur ce forum une réponse mais je n'ai rien trouvé,...

Merci à ceux qui pourrons me donner quelques pistes,

[joe.levrai]

Bonjour,

si l'idée que tu as, c'est de "passer la main" à outlook d'un point de vue "execution de lignes de code VBA", je te déconseille de t'y aventurer.

soit tu travailles totalement dans Outlook, soit dans Excel, mais évite de jouer sur les deux tableaux

après, qui pilote qui ? Ca dépend de l'objectif de tes procédures, nous n'en voyons pas la moindre ligne de code pour le moment

si t'es dans outlook, il faut faire un "GetObject" sur l'instance Excel.Application pour la "capturer" et agir dessus par automation

[Boulatwo]

Bonjour Joe,

Merci beaucoup pour ta réponse. Je ne connaissais pas cette méthode.

Après quelque recherche et test, elle s'applique parfaitement à ce que je veux faire.

Je simplifie mon code pour qu'il soit lisible de tous et le mets dans la discussion pour que chacune puisse en profiter.

[Boulatwo]

Bonjour,

Voici le code associé, largement inspiré de ce que j'ai pu trouver sur le net,...

Code à mettre dans ThisOutlookSession:

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
Dim WithEvents ObjSentItems1 As Items
 
'Inspiré du code de fylyp66 - http://www.developpez.net/
Private Sub Application_Startup()
 
Dim NS As Outlook.NameSpace
Set NS = Application.GetNamespace("MAPI")
 
Set Obj1 = NS.Folders(1)
Set ObjSentItems1 = Obj1.Folders("Éléments envoyés").Items
 
End Sub
 
 
Private Sub ObjSentItems1_ItemAdd(ByVal Item As Object)
 
If Item.Class <> olMail Then GoTo fin
 
'*******************************************************************************************************************************
 
 
Dim AdresseFichier As String
 
'Emplacement du fichier ouvert
AdresseFichier = "C:\Test.xls"
 
 
'****************************************************************************************************************************
 
 
    If (IsFileOpen(AdresseFichier)) Then
        Dim XLapp As Object
        Set XLapp = GetObject(AdresseFichier)
 
        Dim ObjOL As Object, Ligne As Long
 
        Ligne = 0
 
        With XLapp.Sheets(1)
            Ligne = .Cells(.Rows.Count, 2).End(xlUp).Row
 
            For Each ObjOL In ObjSentItems1
                'On peut à ce niveau ajouter des règles de tri sur la date, le sujet,...
                Ligne = Ligne + 1
 
                'Extraction de la date d'envoi et ajout au fichier excel Test
                .Cells(Ligne, 2) = ObjOL.CreationTime
 
                'Extraction de la date d'envoi et ajout au fichier excel Test
                .Cells(Ligne, 3) = ObjOL.Subject
 
                'Extraction du body et ajout au fichier excel Test
                .Cells(Ligne, 4) = ObjOL.Body
 
                'Extraction du destinataire et ajout au fichier excel Test
                .Cells(Ligne, 5) = ObjOL.To
 
                'Extraction de l'envoyeuret ajout au fichier excel Test
                .Cells(Ligne, 6) = ObjOL.SenderName
            Next ObjOL
        End With
 
        Set NS = Nothing
        Set olApp = Nothing
 
 
 
        'Enlève les doublons éventuels de mon extraction outlook sur mon fichier excel
        With XLapp.Sheets(1)
            .Activate
 
            .Range("B2:F" & .Cells(.Rows.Count, 2).End(xlUp).Row).Select
            .Range("B2:F" & .Cells(.Rows.Count, 2).End(xlUp).Row).RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5), Header:=xlYes
        End With
 
        XLapp.Sheets(1).Activate
 
 
    End If
 
 
 
 
'*******************************************************************************************************************************
fin:
 
 
End Sub

Et insérer également dans un module:

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
Function IsFileOpen(filename As String)
    Dim filenum As Integer, errnum As Integer
 
    On Error Resume Next   ' Turn error checking off.
    filenum = FreeFile()   ' Get a free file number.
    ' Attempt to open the file and lock it.
    Open filename For Input Lock Read As #filenum
    Close filenum          ' Close the file.
    errnum = Err           ' Save the error number that occurred.
    On Error GoTo 0        ' Turn error checking back on.
 
    ' Check to see which error occurred.
    Select Case errnum
 
        ' No error occurred.
        ' File is NOT already open by another user.
        Case 0
         IsFileOpen = False
 
        ' Error number for "Permission Denied."
        ' File is already opened by another user.
        Case 70
            IsFileOpen = True
 
        ' Another error occurred.
        Case Else
            Error errnum
    End Select
 
End Function

Encore un grand merci à JOE

[joe.levrai]

Bonjour,

en termes de vitesse d'exécution, écrire à la volée dans le fichier excel piloté par outlook, c'est pas le top. Surtout qu'il suffit que tu "prennes la main" à la place de outlook sur le fichier excel (par exemple tu entres dans une cellule et tu bloques le dialogue entre outlook et excel) et ta procédure va planter

si tu as besoin de gagner en rapidité, tu peux stocker tes résultats dans un tableau interne VBA
et à la fin tu injectes ton tableau en une fois sur la feuille excel

un exemple codé à main levé, que je n'ai pas testé et qui n'est peut être pas exempt d'une coquille à corriger

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
Option Base 1
Dim WithEvents ObjSentItems1 As Items
 
Private Sub ObjSentItems1_ItemAdd(ByVal Item As Object)
Dim AdresseFichier As String, ObjOL As Object, Tabl(), Existe As Boolean
    If Item.Class <> olMail Then GoTo fin
        AdresseFichier = "C:\Test.xls"
 
        If (IsFileOpen(AdresseFichier)) Then
            For Each ObjOL In ObjSentItems1
                If Not Existe Then
                    ReDim Tabl(5, 1)
                    Existe = True
                Else
                    ReDim Preserve Tabl(UBound(Tabl, 1), UBound(Tabl, 2) + 1)
                End If
 
                With ObjOL
                    Tabl(1, UBound(Tabl, 2)) = .CreationTime
                    Tabl(2, UBound(Tabl, 2)) = .Subject
                    Tabl(3, UBound(Tabl, 2)) = .Body
                    Tabl(4, UBound(Tabl, 2)) = .To
                    Tabl(5, UBound(Tabl, 2)) = .SenderName
                End With
            Next ObjOL
 
            With GetObject(AdresseFichier)
                With .Sheets(1)
                    .Cells(.Rows.Count, 2).End(xlUp).Resize(UBound(Tabl, 2), UBound(Tabl, 1)).Value = .Application.Transpose(Tabl)
                    .Range("B2:F" & .Cells(.Rows.Count, 2).End(xlUp).Row).RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5), Header:=xlYes
                End With
            End With
        End If
    End If
End Sub

EDIT : une petite modif, encore à main levée, faut tester et me faire un retour, je n'ai pas outlook sous la main

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
Option Base 1
Dim WithEvents ObjSentItems1 As Items
 
Private Sub ObjSentItems1_ItemAdd(ByVal Item As Object)
Dim AdresseFichier As String, ObjOL As Object, Tabl(), Existe As Boolean
    If Item.Class <> olMail Then GoTo fin
        AdresseFichier = "C:\Test.xls"
 
        If (IsFileOpen(AdresseFichier)) Then
            With ObjSentItems1
                ReDim Tabl(.Count, 5)
 
                With .items(i)
                    Tabl(i, 1) = .CreationTime
                    Tabl(i, 2) = .Subject
                    Tabl(i, 3) = .Body
                    Tabl(i, 4) = .To
                    Tabl(i, 5) = .SenderName
                End With
            End With
 
            With GetObject(AdresseFichier)
                With .Sheets(1)
                    .Cells(.Rows.Count, 2).End(xlUp).Resize(UBound(Tabl, 1), UBound(Tabl, 2)).Value = Tabl
                    .Range("B2:F" & .Cells(.Rows.Count, 2).End(xlUp).Row).RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5), Header:=xlYes
                End With
            End With
        End If
    End If
End Sub

[Boulatwo]

Bonjour Joe,

J'ai enfin testé le code,...

Il semble qu'il y ait une certaine incompatibilité d'utilisation entre option base 1 et RemoveDuplicates...

On lève facilement le problème en travaillant en option base 0 (de base) et en modifiant légèrement le code.

Enfin dans ton dernier bout de code tu boucle sur une variable 'i' qui ne bouge pas et qui n'est pas définie, .... mais j'ai bien compris ou tu voulais en venir.

Le reste fonctionne et on gagne bien en rapidité,

Merci encore pour ton aide