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
| Private Sub piecejointe()
'Declaration
Dim myItems, myItem, myAttachments, myAttachment As Object
Dim myOrt As String
Dim myOlApp As New Outlook.Application
Dim myOlExp As Outlook.Explorer
Dim myOlSel As Outlook.Selection
Dim i As Integer
Dim fichier As String
'Boîte de dialogue simple pour le chemin de sauvegarde
myOrt = InputBox("Destination", "Save Attachments", "h:\mail\")
On Error Resume Next
'Actions sur les objets sélectionnés
Set myOlExp = myOlApp.ActiveExplorer
Set myOlSel = myOlExp.Selection
'boucle
For Each myItem In myOlSel
Set myAttachments = myItem.Attachments
If myAttachments.Count > 0 Then
'Ajoute une remarque dans le corps du message
myItem.Body = myItem.Body & vbCrLf & _
"pièce jointe enlevée:" & vbCrLf
'for all attachments do...
For i = 1 To myAttachments.Count
'save them to destination
myAttachments(i).SaveAsFile myOrt & _
myAttachments(i).DisplayName
fichier = myAttachments(i).DisplayName
fichier = Replace(fichier, " ", "%20")
myItem.Body = myItem.Body & _
"File: " & "file:///" & myOrt & fichier & vbCrLf
'C:\Documents and Settings\edeneuve\Mes documents\css.htm
Next i
'<p class=MsoNormal><a href="file:///\\MDC92401\edeneuve$\mail">H:\mail\</a><o:p></o:p></p>
'Enlève les pièces jointes du message
While myAttachments.Count > 0
myAttachments(1).Delete
Wend
'Sauvegarde le message sans ses pièces jointes
myItem.Save
End If
Next
Set myItems = Nothing
Set myItem = Nothing
Set myAttachments = Nothing
Set myAttachment = Nothing
Set myOlApp = Nothing
Set myOlExp = Nothing
Set myOlSel = Nothing
End Sub |
Partager