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.