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
| Sub LireMessagesDUnDossierEtLeDeplacerVersUnAutre()
'Réf.sdispro.xlsm
Dim olApp As Object, NS As Object, Dossier As Object
Dim DossierDest As Object, DossierCible As Object
Dim i As Object, x As Long, R As Object, Ligne As Long
Set olApp = CreateObject("Outlook.Application")
Set NS = olApp.GetNamespace("MAPI")
Set DossierSource = NS.Folders(1).Folders("Boîte de réception").Folders("essai")
Set DossierDest = NS.Folders(1).Folders("Boîte de réception").Folders("traiter")
With Sheets("Feuil1")
Ligne = .Cells(.Rows.Count, 3).End(xlUp).Row
For Each i In DossierSource.Items
Ligne = Ligne + 1
.Cells(Ligne, 1) = i.SenderName
.Cells(Ligne, 2) = i.Subject
Ligne = Ligne + 1
For x = 0 To UBound(Split(i.Body, vbCrLf))
Ligne = Ligne + 1
.Cells(Ligne, 3) = Split(i.Body, vbCrLf)(x)
Next x
.Columns(3).ColumnWidth = 185
.Columns(3).Cells.WrapText = True
'*** bordures
With .Range(.[A2], .Cells(Ligne, 3))
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.Weight = xlThin
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.Weight = xlThin
End With
With .Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.Weight = xlThin
End With
End With
With .Range(.Cells(Ligne, 1), .Cells(Ligne, 3))
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.Weight = xlThin
End With
End With
'sauvegarde du message sous forme de fichier. Possibilité de mettre un lien hypertexte pour l'ouvrir dans Outlook
'i.SaveAs "c:temp\" & Format(i.CreationTime, "yyyy-mm-dd hh""h""mm") & " - " & i.Subject & ".msg", olMSG
i.Move DossierDest
Next i
End With
Set NS = Nothing
Set olApp = Nothing
End Sub |
Partager