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 |
Partager