Copy and merge word doc. attachments from outlook?

[drgoodvibe]

Hi there,

I'm a VB noob, any help would be appreciated.

I'd like to modify this code, so that not only it saves the word document attachment on your computer from the email, but also merges the documents into 1 large file document.

I would also be getting multiple docs with the same filename. I've looked at several options on this site,

Sub SaveAttachment()
 
    '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
    
    'Ask for destination folder
    myOrt = InputBox("Destination", "Save Attachments", "C:\")
 
    On Error Resume Next
    
    'work on selected items
    Set myOlExp = myOlApp.ActiveExplorer
    Set myOlSel = myOlExp.Selection
    
    'for all items do...
    For Each myItem In myOlSel
    
        'point on attachments
        Set myAttachments = myItem.Attachments
        
        'if there are some...
        If myAttachments.Count > 0 Then
        
            'add remark to message text
            myItem.Body = myItem.Body & vbCrLf & _
                "Removed Attachments:" & vbCrLf
                
            'for all attachments do...
            For i = 1 To myAttachments.Count
            
                'save them to destination
                myAttachments(i).SaveAsFile myOrt & _
                    myAttachments(i).DisplayName
 
                'add name and destination to message text
                myItem.Body = myItem.Body & _
                    "File: " & myOrt & _
                    myAttachments(i).DisplayName & vbCrLf
                    
            Next i
            
            'for all attachments do...
            'While myAttachments.Count > 0
            
                'remove it (use this method in Outlook XP)
                'myAttachments.Remove 1
                
                'remove it (use this method in Outlook 2000)
                'myAttachments(1).Delete
                
            Wend
            
            'save item without attachments
            myItem.Save
        End If
        
    Next
    
    'free variables
    Set myItems = Nothing
    Set myItem = Nothing
    Set myAttachments = Nothing
    Set myAttachment = Nothing
    Set myOlApp = Nothing
    Set myOlExp = Nothing
    Set myOlSel = Nothing
    
End Sub

I thought about using this code here to look for docs with the same filename and change them. However i'm not sure how to implement it.

If ActiveWorkbook.Saved = True Then
        Dim sName As String
        Dim i As Integer
        Dim bNum As Boolean
        sName = ActiveWorkbook.Name
        'look for the version number
        i = 1
        Do While bNum = False
            If IsNumeric(Mid$(ActiveWorkbook.Name, i, 1)) = True Then
                bNum = True
                Exit Do
            End If
            i = i + 1
        Loop
        If bNum = True Then
            'Save and increment the number by 1
            ActiveWorkbook.SaveAs Replace(ActiveWorkbook.Name, Mid$(ActiveWorkbook.Name, i, 1), Mid$(ActiveWorkbook.Name, i, 1) + 1)
        Else
            'Add a 1 to the end of the name
            ActiveWorkbook.SaveAs Replace(ActiveWorkbook.FullName, ".xls", "1.xls")
        End If
    Else 'New book so save with name and 1.xls
        ActiveWorkbook.SaveAs "C:\SomeFileName1.xls"
    End If

The whole thing would be to take multiple emails pull there attachments from outlook, and merge them all into one word document. However some of the docs have the same filename, eventhough there contents would not be the same. Any help or guidence would be much appreciated. I'm getting tons of errors here and there, so i'm not even sure where to exactly how to merge these two very different scripts.