Outlook Attachments, redux

[strebor]

I am trying to creat a macro that copies the attachments from a selection of emails and places them in another Outlook folder. From the documentation, I know this can't be done directly. One must save the files to a Windows directory (for example ...\local settings\temp ) and then ? Well, I know they can be re-attached to another object, like a task, but can they be just copied to an Outlook folder? This would not be my first choice, but my customer would like to see it.

Here is my macro...

Public Sub copyAttachments()
    Dim objOL As Outlook.Application
    Dim objMsg As Object
    Dim objAttachments As Outlook.Attachments
    Dim objSelection As Outlook.Selection
    Dim objNS As Outlook.NameSpace
    Dim objTarget As Object
    Dim i As Long
    Dim k As Long
    Dim lngCount As Long
    Dim strFile As String
    Dim strFolder As String
    Dim intLoc As Long
    Dim strFileExt As String
    Dim strFileName As String
    Dim strFileTemp As String
    Dim fso
    Dim FldTemp
    Dim strPrefix
    Dim WshNetwork
    Dim UserId
    
    
    strPrefix = InputBox("Please provide a simple prefix for the attachments. A case number, perhaps?", _
                            "Prefix files with...", _
                            "2006-")

    'On Error Resume Next

    ' Instantiate an Outlook Application object.
    Set objOL = CreateObject("Outlook.Application")
    Set objNS = objOL.GetNamespace("MAPI")
    ' Get the collection of selected objects.
    Set objSelection = objOL.ActiveExplorer.Selection
    'Set objTarget = objNS.PickFolder

    Set fso = CreateObject("Scripting.FileSystemObject")
    'FldTemp = "c:\documents and settings\cnr4953\my documents\email\" 'fso.GetSpecialFolder(TemporaryFolder)
    Set FldTemp = fso.GetSpecialFolder(2)
    
    FldTemp = FldTemp & "\"

    ' Check each selected item for attachments.
    ' If attachments exist, save them to the Temp
    ' folder and strip them from the item.
    For Each objMsg In objSelection
        ' This code only strips attachments from mail items.
        If objMsg.Class = olMail Then
            ' Get the Attachments collection of the item.
            Set objAttachments = objMsg.Attachments
            lngCount = objAttachments.Count
            If lngCount > 0 Then
                ' We need to use a count down loop for
                ' removing items from a collection. Otherwise,
                ' the loop counter gets confused and only every
                ' other item is removed.
                For i = lngCount To 1 Step -1
                    ' Save attachment before deleting from item.
                    ' Get the file name.
                    strFile = objAttachments.Item(i).FileName
                    strFileName = strFile
                    ' Combine with the path to the Temp folder.
                    ' Save the attachment as a file.
                    strFilePath = FldTemp & strPrefix & "_" & strFile

                    If fso.FileExists(strFilePath) Then
                                               
                        intLoc = InStrRev(strFileName, ".")

                        strFileTemp = Left(strFileName, intLoc - 1)

                        strFileExt = Mid(strFileName, intLoc + 1)
                        
                        
                        k = 1
                        Do
                            strFilePath = FldTemp & strPrefix & "_" & strFileTemp & CStr(k) & "." & strFileExt
                            k = k + 1
                            
                        Loop While fso.FileExists(strFilePath)
                    End If
                    
                    objAttachments.Item(i).SaveAsFile strFilePath
'======================================================
'this is the part where I am stuck...

                    'objTarget.Messages.Add strFilePath, olByValue, , objAttachment.Item(i).DisplayName
'======================================================                    
                Next i
            End If
            objMsg.Save
        End If
    Next
    MsgBox "All done. Look for files in ...local settings\temp"
ExitSub:
    Set objAttachments = Nothing
    Set objMsg = Nothing
    Set objSelection = Nothing
    Set objOL = Nothing
    Set fso = Nothing
End Sub