Option Explicit
Public Sub InsertAttachmentsTest()
Dim objMail As Outlook.MailItem
Dim objAnswer As Outlook.MailItem
Dim objAttachment As Outlook.Attachment
Dim objAttachments As Outlook.Attachments
Dim strMyDocuments As String
Dim strAttachment As String
Dim objSelection As Outlook.Selection
Dim i As Integer
On Error Resume Next
Set objSelection = Application.ActiveExplorer.Selection
Set objMail = Outlook.ActiveExplorer.Selection(i)
i = 0
If objSelection.Count = 0 Then GoTo ExitProc
Set objAnswer = Outlook.ActiveInspector.CurrentItem
Set objAttachments = objMail.Attachments
strMyDocuments = GetMyDocuments
If objSelection.Count > i Then i = i + 1
Speichern:
For Each objAttachment In objAttachments
Call objAttachment.SaveAsFile(strMyDocuments & "\" & objAttachment.FileName)
Call objAnswer.Attachments.Add(strMyDocuments & "\" & objAttachment.FileName)
Call Kill(strMyDocuments & "\" & objAttachment.FileName)
If objSelection.Count > i Then i = i + 1: GoTo Speichern:
If objSelection.Count = i Then GoTo ExitProc:
Next
ExitProc:
Set objMail = Nothing
Set objAnswer = Nothing
Set objAttachment = Nothing
Set objAttachments = Nothing
End Sub
Private Function GetMyDocuments() As String
Dim objWshShell As Object
On Error Resume Next
Set objWshShell = CreateObject("WScript.Shell")
GetMyDocuments = objWshShell.SpecialFolders("MyDocuments")
Set objWshShell = Nothing
End Function