Saving Outlook Attachments with same filename.

[XP2000]

I have the code to automate the saving of attachments for emails received in Outlook.

http://www.freevbcode.com/ShowCode.asp?ID=1154&NoBox=True

This works fine when the attachments have different filenames. What I can't figure out is a way to automate this procedure when all the attachments have the same filename.
Help greatly appreciated.

 

[BVerlaan]

Perhaps you should try this:

Public Function PathAndFileExist (ByVal PathToFile As String, _
ByVal FileName As String) As Boolean

Dim FSys As Object 'object that represents the Filesystem

PathAndFileExist = False
Set FSys = CreateObject("Scripting.FileSystemObject&quot

'FSys.FileExists( . . . ) returns True if file exists
PathAndFileExist = FSys.FileExists(PathToFile & FileName)

Set FSys = Nothing 'disconnect

End Function

This Functions returns a True if the file already exists in the folder. If so, rename the file (or save the file in another folder or whatever you want). Call the function in the loop that saves the attachments. And decide what to do depending on the value the function returns.

Good luck, Bart Verlaan.

 

[BVerlaan]

ps, you must have Windows Scripting Host installed on your computer. Otherwise the function won't work. I know this is a security risk, but I don't know another way to get access to the filesystem.

Bart V.

 

[XP2000]

Good stuff.
I had to adapt some of my code, but I got it to work.

Here's my code for reference:
'=========================================================
Private Sub CmdAnalyse_Click()

Dim ObjOutlook, MyNamespace, oFldr, myFldr, myMailItem, myAttach As Object
Dim i, j, k, x As Integer
Dim myDiskFolder As String
myDiskFolder = "c:\new\" 'Folder on hard disk to save attachments

Set ObjOutlook = Outlook.Application
Set MyNamespace = ObjOutlook.GetNamespace("MAPI&quot
Set oFldr = MyNamespace.GetDefaultFolder(olFolderInbox)
Set myFldr = oFldr.Folders.Item(13) 'My subfolder in Inbox that holds attachments

For i = 1 To myFldr.Items.Count
Set myMailItem = myFldr.Items.Item(i)

For k = 1 To myMailItem.Attachments.Count
'save each mail attachment
Set myAttach = myMailItem.Attachments
If PathAndFileExist(myDiskFolder, x & myAttach.Item(k).DisplayName) = True Then x = x + 1
'Saves duplicate attachments to hard disk as 0xxx.xls,1xxx.xls,2xxx.xls etc
myAttach.Item(k).SaveAsFile myDiskFolder & x & myAttach.Item(k).DisplayName

Next k
Next i

Set ObjOutlook = Nothing: Set MyNamespace = Nothing
Set oFldr = Nothing: Set myFldr = Nothing
Set myMailItem = Nothing: Set myAttach = Nothing

End Sub
'------------------------------------------------------
Public Function PathAndFileExist(ByVal PathToFile As String, _
ByVal FileName As String) As Boolean

Dim FSys As Object 'object that represents the Filesystem

PathAndFileExist = False
Set FSys = CreateObject("Scripting.FileSystemObject&quot

'FSys.FileExists( . . . ) returns True if file exists
PathAndFileExist = FSys.FileExists(PathToFile & FileName)

Set FSys = Nothing 'disconnect

End Function
'======================================================