Alimenter une listobx depuis certains éléments seulement d'un tableau(1000,6)

**Theophile69** · 12/06/2018, 08h44

Bonjour à tous,

j'ai un programme qui relève depuis Excel des centaines de mail dans Outlook

.
A chaque mail passé en revue, je récupère différentes informations que je mets dans un tableau (tableau que j'ai surdimmensinoné afin d'éviter un Redim Preserve à chaque tour de boucle).

Seulement voilà, lorsque j'envoie le tableau dans un listbox pour interraction utilisateur, la listbox contient énormément de lignes non remplies

, qu'il me faudrait encore une fois passer inutilement en revue lorsque je repère l'item sélectionné par exemple.

Je souhaite donc que la listbox contienne seulement les élémenst existant du tableau en utilisant par exemple le compteur "i" que j'incrémente à chaque mail identifié...

Quelqu'un pourrait-il m'aider?

(J'ai entendu dire que la méthode .add pouvait provoquer une erreur s'il y a vraiment beaucoup d'élémént).

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
 
Sub importerMailsDemandesMedecins()
 
'DECLARATIOND DES VARIABLES SIMPLES
Dim listeDemande(1000, 6) As String
Dim i As Integer
 
'ATTRIBUTION DES VALEURS
i = 0
 
'DECLARATION DES VARIABLES D'APPLICATION
'variables application outlook et attribution de valeurs
Dim objOutlook As Outlook.Application                                   'Application outlookk
    Set objOutlook = New Outlook.Application
Dim objNameSpace As Outlook.Namespace                                       'Espace outlook
    Set objNameSpace = Outlook.GetNamespace("MAPI")
Dim objFol As Outlook.Folder                                                    'Dossier outlook
    Set objFol = objNameSpace.GetDefaultFolder(olFolderInbox)
Dim objMail As Outlook.MailItem                                                     'Email outlook
    Set objMail = objOutlook.CreateItem(olMailItem)
Dim objAtmt As Outlook.Attachment                                                       'Pièce-jointe outlook
 
 
'RECHERCHE DES PIECE JOINTE TYPE STETHO DANS TOUS LES MESSAGES
For Each objMail In objFol.Items
    For Each objAtmt In objMail.Attachments
 
        If objAtmt.Filename Like "*#########.pdf" Then  'Nom pièce jointe avec des chiffres (#) et .pdf
            'ALIMENTATION TABLEAU DE VALEUR VIRTUEL
            listeDemande(i, 0) = i + 1                          'Ordre d'arrivee
            listeDemande(i, 1) = objMail.ReceivedTime           'Date
            listeDemande(i, 2) = objMail.Sender                 'Expediteur
            listeDemande(i, 3) = objMail.Subject                'Objet
            listeDemande(i, 4) = objMail.Body                   'Contenu
            listeDemande(i, 5) = objAtmt.Filename               'Nom pièce jointe
                If objMail.Body Like "*Demande importee le*" Then
                listeDemande(i, 6) = "Traité"                              'Statut traite/nontraite
                Else
                listeDemande(i, 6) = "NEW"
                End If
                    i = i + 1
                        If i >= 1000 Then
                        MsgBox "Votre boite de réception contient plus de 1000 demandes médecins. Merci de bien vouloir archiver les anciennes demandes pour utiliser de nouveau l'importation automatique."
                        Exit Sub
                        End If
        End If
    Next objAtmt
Next objMail
 
'ALIMENTATION DE LA LISTBOX DU USER FORME DEMANDESMEDECINS
DemandesMedecins.ListBox1.List() = listeDemande
 
'INITIALISATION DES VARIABLES D'APPLICATION
'variables application outlook et attribution de valeurs
 
    Set objOutlook = Nothing
    Set objNameSpace = Nothing
    Set objFol = Nothing
    Set objMail = Nothing

**pijaku** · 12/06/2018, 08h57

Bonjour,

Sers toi donc de i, mais, au préalable, il te faut inverser les dimensions de ton tableau :

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
            Dim listeDemande() As String
            ReDim listeDemande(6, 1000)
 
'REMPLISSAGE...
            listeDemande(0, i) = i + 1                          'Ordre d'arrivee
            listeDemande(1, i) = objMail.ReceivedTime           'Date
            listeDemande(2, i) = objMail.Sender                 'Expediteur
            listeDemande(3, i) = objMail.Subject                'Objet
            listeDemande(4, i) = objMail.Body                   'Contenu
            listeDemande(5, i) = objAtmt.Filename               'Nom pièce jointe
                If objMail.Body Like "*Demande importee le*" Then
                listeDemande(6, i) = "Traité"                              'Statut traite/nontraite
                Else
                listeDemande(6, i) = "NEW"
                End If
 
            ReDim Preserve listeDemande(0 To 6, 0 To i)
            DemandesMedecins.ListBox1.List() = Application.Transpose(listeDemande)

**Theophile69** · 12/06/2018, 09h10

Bonjour Pijaku,
merci.

Envoyé par pijaku

Bonjour,

Ta variable i te sert de compteur, utilises la, en fin de macro, pour Redimensionner ton tableau :

Code :

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

1
2
3
ReDim Preserve listeDemande(0 To i, 0 To 6)
'ALIMENTATION DE LA LISTBOX DU USER FORME DEMANDESMEDECINS
DemandesMedecins.ListBox1.List() = listeDemande

**pijaku** · 12/06/2018, 09h11

Prends ma dernière modification ci-dessus.

**joe.levrai** · 12/06/2018, 12h58

Bonjour,

plutôt que de boucler mail par mail pour récupérer les éléments, tu peux exporter quasi instantanément la table des données des mails d'un dossier

voici un exemple de Oliv qui pourrait t'inspirer
teste le tel quel pour voir si c'est une piste qui t'intéresse

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
139
140
141
142
143
144
145
146
Sub ExportFolderItemsToExcel()
'---------------------------------------------------------------------------------------
' Procedure : ExportFolderItemsToExcel
' Author    : Oliv
' Date      : 10/11/2017
' Purpose   : export des informations d'Emails de la boite de reception vers excel
'---------------------------------------------------------------------------------------
'
    Dim oFolder As Object
    Dim criteria
    Dim oTable As Object
    Dim i, oRow, R, arr
 
    Const olFolderInbox = 6
    Const olUserItems = 0
 
    Dim OL As Object
    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(olFolderInbox).Store.GetSearchFolders.item("tout")
 
    'si on veut choisir
    Set oFolder = OL.Session.PickFolder
 
 
    'Pour ne prendre que les EMAILS
    'criteria = "[MessageClass]='IPM.Note' or [MessageClass]='IPM.Post'"
 
    'Pour tous les éléments
    criteria = "[MessageClass]<>'zzz'"
 
 
    Set oTable = oFolder.GetTable(criteria, olUserItems)
    MsgBox oTable.GetRowCount
    On Error Resume Next
    With oTable.Columns
        .RemoveAll
        .Add ("Subject")
        .Add ("CreationTime")
        .Add ("LastModificationTime")
        .Add ("MessageClass")
        .Add ("ReceivedTime")
        .Add ("Senton")
        .Add ("Size")
        .Add ("To")
        .Add ("Cc")
        .Add ("Bcc")
        .Add ("Categories")
        .Add ("ConversationTopic")
        .Add ("ReceivedByName")
        .Add ("SenderName")
        .Add ("SenderEmailAddress")
        .Add ("Unread")
        .Add ("http://schemas.microsoft.com/mapi/proptag/0x0E1B000B")    'PR_HASATTACH
        .Add ("ConversationIndex")
        .Add ("http://schemas.microsoft.com/mapi/proptag/0x66700102")
        .Add ("http://schemas.microsoft.com/mapi/proptag/0x1000001F")    '="Body"
        ''.Add ("Sent") 'KO
        ''.Add ("Duration") 'KO
        ''.Add ("Type") 'KO
 
    End With
    'MsgBox oTable.GetRowCount
 
    Dim AppExcel As Object
    Dim Wk As Object, Ws As Object
    If InStr(1, Application, "Excel", vbTextCompare) > 0 Then
        Set AppExcel = Application
    Else
        Set AppExcel = CreateObject("Excel.application")
        AppExcel.Visible = True
    End If
    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.item(i).Name
        If Ws.Cells(1, i).Value = "http://schemas.microsoft.com/mapi/proptag/0x0E1B000B" Then Ws.Cells(1, i).Value = "PR_HASATTACH"
        If Ws.Cells(1, i).Value = "http://schemas.microsoft.com/mapi/proptag/0x66700102" Then Ws.Cells(1, i).Value = "EntryIdLong"
        If Ws.Cells(1, i).Value = "http://schemas.microsoft.com/mapi/proptag/0x1000001F" Then Ws.Cells(1, i).Value = "Body"
    Next i
    Ws.Cells.NumberFormat = "@"
    Ws.Range("C:H").NumberFormat = "General"
 
    'GoTo parcourir
    '     one row spanning several columns
    oTable.Sort "LastModificationTime", True
    arr = oTable.GetArray(oTable.GetRowCount)
 
    Dim Destination As Object
    Set Destination = Ws.Range("a2")
    Set Destination = Destination.Resize(UBound(arr, 1) + 1 - LBound(arr, 1), UBound(arr, 2) + 1 - LBound(arr, 2))
 
    On Error Resume Next
    Destination.Value = arr
 
    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
    Ws.Cells.WrapText = True
    Ws.Cells.WrapText = False
    Exit Sub
 
End Sub

**Theophile69** · 19/06/2018, 08h30

Merci JoeLevrai et Pijaku de tous ces éléments qui m'ont beaucoup aidé.
A charge de revanche

Alimenter une listobx depuis certains éléments seulement d'un tableau(1000,6)

Macros et VBA Excel

Vue hybride

Discussions similaires

Partager

Partager