[OL 2013] Sélection multiple de tâches dans le journal

**jerem512** · 21/01/2017, 17h17

Bonjour,

J'ai dans mon journal une multitude de tâche rangéé en fonction de la première lettre du nom et du prénom de la personne (exemple: JG)

J'aimerais pouvoir imprimer seulement les tâches contenant au début de l'objet JG.

Cette une tâche répétitive toutes les semaines.

Je n'arrive pas à faire en VBA la sélection multiple.

Voici le début de la macro que je pensais faire:

Dim MonApply As Outlook.Application
Dim MonNSpace As Outlook.NameSpace
Dim FldDossier As Outlook.Folder
Dim MonJournal As Outlook.JournalItem

'Instance des Objets
Set MonApply = Outlook.Application 'Application Outlook
Set MonNSpace = MonApply.GetNamespace("MAPI") 'Banque MAPI
Set FldDossier = MonNSpace.GetDefaultFolder(olFolderJournal) 'Dossier journal
'Boucle afin de parcourir l'ensemble des taches du journal présents dans le dossier journal
For i = 1 To FldDossier.Items.Count
'instancie la tache suivant la valeur de la boucle
Set MonJournal = FldDossier.Items(i)
'Test sur le sujet contient "JG"
If MonJournal.Subject Like "*JG*" Then

"Selection de l'ITEM"

End If
Next i

'Vide des instances
Set MonApply = Nothing
Set MonNSpace = Nothing
Set FldDossier = Nothing
Set MonJournal = Nothing

End Sub

Merci pour votre aide.

**jerem512** · 22/01/2017, 19h10

Bonjour,

J'ai réussi à sélection les entrées de journal avec cette ligne.

Application.ActiveExplorer.AddToSelection MonJournal

Par contre, Je voudrais pouvoir imprimer cette sélection en mode tableau.
J'arrive à faire fonctionner printout seulement sur un seul item.

Dites moi si vous avez une solution.
Merci

**Oliv-** · 23/01/2017, 17h06

Bonjour,
Tu ne pourras pas via VBA de cette façon là.

La solution c'est d'exporter les lignes vers excel et d'imprimer avec excel.

Pour filtrer c'est dans criteria : il faut utiliser une requête Microsoft Jet ou DASL voir

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
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
 
Sub ExportFolderItemsToExcel()
'---------------------------------------------------------------------------------------
' Procedure : ExportFolderItemsToExcel
' Author    : Oliv
' Date      : 04/11/2016
' Purpose   :
'---------------------------------------------------------------------------------------
'
    Dim oFolder As Outlook.Folder
    Dim criteria
    Dim oTable As Table
    Dim i, oRow, R, arr
 
 
        Dim OL As Outlook.Application
    If UCase(Application) = "OUTLOOK" Then
        Set OL = Application
    Else
        Set OL = CreateObject("outlook.application")
    End If
 
    'Si on connait le nom
            Set oFolder = OL.Session.GetDefaultFolder(olFolderJournal)
 
    'si on veut choisir
 
    'Set oFolder = OL.Session.PickFolder
'    criteria = "[MessageClass]='IPM.Note' or [MessageClass]='IPM.Post'"
    criteria = "[MessageClass]='IPM.Activity'"
 
    Set oTable = oFolder.GetTable(criteria, olUserItems)
    On Error Resume Next
    With oTable.Columns
        .Add ("Duration")
        .Add ("Type")
        '.add ("LastModificationTime")
        .Add ("ReceivedTime")
        .Add ("ReceivedTime")
        .Add ("Senton")
        .Add ("Size")
        .Add ("To")
        .Add ("Cc")
        .Add ("Bcc")
        .Add ("Categories")
        .Add ("ConversationTopic")
        .Add ("ReceivedByName")
        .Add ("SenderName")
        '.add ("Sent")
        .Add ("SenderEmailAddress")
        .Add ("Unread")
        .Add ("http://schemas.microsoft.com/mapi/proptag/0x0E1B000B")    'PR_HASATTACH
        '.add ("http://schemas.microsoft.com/mapi/proptag/0x0E13000D") 'PR_MESSAGE_ATTACHMENTS
        '.add ("http://schemas.microsoft.com/mapi/proptag/0x37010102") 'PR_ATTACH_DATA_BIN
        '.add ("http://schemas.microsoft.com/mapi/proptag/0x0EA5001E") 'PR_SEARCH_ATTACHMENTS
        '.add ("http://schemas.microsoft.com/mapi/proptag/0x0E12000D") 'PR_MESSAGE_RECIPIENTS
        '"http://schemas.microsoft.com/mapi/proptag/0x0E13000D"
        '.add ("BodyFormat") KO
        '.add ("HTMLBody")KO
        .Add ("http://schemas.microsoft.com/mapi/proptag/0x1000001F") '="Body"
       ' .add (" http://schemas.microsoft.com/mapi/id/{00062008-0000-0000-C000-000000000046}/8596001E") 'attach name
 
 
    End With
    MsgBox oTable.GetRowCount
 
    Dim AppExcel As Object
    Dim Wk As Object, Ws As Object
    Set AppExcel = CreateObject("Excel.application")
    AppExcel.Visible = True
    Set Wk = AppExcel.Workbooks.Add
    Set Ws = Wk.ActiveSheet
 
    R = 2
    'Enumerate the table using test for EndOfTable
    For i = 1 To oTable.Columns.Count
        Ws.Cells(1, i).Value = oTable.Columns(i).Name
        If Ws.Cells(1, i).Value = "http://schemas.microsoft.com/mapi/proptag/0x0E1B000B" Then Ws.Cells(1, i).Value = "PR_HASATTACH"
 
    Next i
    Ws.Cells.NumberFormat = "@"
    Ws.Range("C:H").NumberFormat = "General"
 
    'GoTo parcourir
    '     one row spanning several columns
    oTable.Sort ("LastModificationTime")
    arr = oTable.GetArray(oTable.GetRowCount)
 
    Dim Destination As Range
    Set Destination = Ws.Range("a2")
    Set Destination = Destination.Resize(UBound(arr, 1) + 1 - LBound(arr, 1), UBound(arr, 2) + 1 - LBound(arr, 2))
 
    Debug.Print Destination.Address
    On Error Resume Next
    Destination.Value = arr
    'EF000000762056220F897F4AA3A8C342ACB4D74964A9B401
    If Err = 1004 Then GoTo parcourir
    'quand cela ne marche pas cela vient du format de la colonne destination
    On Error GoTo 0
    GoTo mef
 
    'AUTRE METHODE on ecrit en parcourant les enregistrement et les colonnes
parcourir:
    'pour parcourir la table champs par champs
    oTable.MoveToStart
    Do Until (oTable.EndOfTable)
        On Error Resume Next
        Set oRow = oTable.GetNextRow()
        For i = 1 To oTable.Columns.Count
            Debug.Print oRow("Body")
            AppExcel.Cells(R, i).Value = oRow(oTable.Columns(i).Name)
        Next i
 
        R = R + 1
    Loop
 
    GoTo mef
 
mef:
 
    'mise en forme
    With Ws.Cells
        .AutoFilter
        .EntireColumn.AutoFit
    End With
 
    With Ws.Rows("1:1").Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 65535
        .TintAndShade = 0
        .PatternTintAndShade = 0
        .Parent.Font.Bold = True
    End With
 
    Exit Sub
 
End Sub

**jerem512** · 23/01/2017, 18h22

Bonjour,

Merci pour votre réponse.

Cependant je ne connais les filtres par requête Microsoft JET ou DASL et je souhaiterais transférer lorsque l'objet contient "JG" (par exemple).

Pourriez vous m'aidez?

Merci

**Oliv-** · 24/01/2017, 09h44

Bonjour,

Pour la syntaxe des filtres il faut regarder l'aide sur Items.Find, méthode

Essaye en remplaçant criteria par

Code :

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

1
2
criteria = "@SQL= " & Chr(34) & "http://schemas.microsoft.com/mapi/proptag/0x0037001f" _
& Chr(34) & " like " & "'%JG%'"

[OL 2013] Sélection multiple de tâches dans le journal

VBA Outlook

Discussions similaires

Partager

Partager