not tested yet:
Sub SaveOlAttachments()
Dim msg As Outlook.MailItem
Dim att As Outlook.Attachment
Dim strFilePath As String
Dim strAttPath As String
'arnelgp
Dim bolExists As Boolean
Dim sNewFile As String
'path for creating msgs
strFilePath = "C:\New\1\"
'path for saving attachments
strAttPath = "C:\New\2\"
'* create the folder
Call ForceMkDir(strAttPath)
strfile = Dir(strFilePath & "*.msg")
Do While Len(strfile) > 0
Set msg = Application.CreateItemFromTemplate(strFilePath & strfile)
If msg.Attachments.Count > 0 Then
For Each att In msg.Attachments
' arnelgp
' do we need to overwrite if the file already exists on target folder?
' currently, it will not and just go to next
' attachment
'
'the "new" filename format:
' [serial number] + [extension]
'
sNewFile = Val(strfile) & " " & att.Filename
With CreateObject("Scripting.FileSystemObject")
bolExists = .FileExists(strAttPath & sNewFile)
End With
If Not bolExists Then
' arnelgp
att.SaveAsFile serialFile(strAttPath & sNewFile)
'att.SaveAsFile strAttPath & att.Filename
End If
Next
End If
strfile = Dir$
Loop
End Sub
'******************************************
'* arnelgp
'*
'* purpose:
'*
'* make a folder
'*
'******************************************
Public Sub ForceMkDir(ByVal path As String)
Dim var As Variant
Dim i As Integer
Dim s As String
var = Split(path, "\")
On Error Resume Next
For i = 0 To UBound(var)
s = s & var(i)
VBA.MkDir s
s = s & "\"
Next
Erase var
End Sub
'******************************************
'* arnelgp
'*
'* purpose:
'*
'* get the file extension
'*
'******************************************
Public Function getExt(ByVal path As String) As String
Dim iX As Integer
iX = InStrRev(path, ".")
If Len(path) - iX < 5 Then
getExt = Mid$(path, iX + 1)
End If
End Function
'******************************************
'* arnelgp
'*
'* purpose:
'*
'* make a serialized file
'*
'******************************************
Public Function serialFile(ByVal fullpath As String) As String
Dim Ext As String 'the file extension
Dim file As String 'the filename
Dim path As String 'the path
Dim iX As Integer
Dim sNew As String
iX = InStrRev(fullpath, "\")
file = Mid$(fullpath, iX + 1)
path = Replace$(fullpath, file, "")
iX = InStrRev(file, ".")
If iX <> 0 Then
Ext = Mid$(file, iX)
End If
file = Replace$(file, Ext, "")
iX = 0
sNew = path & file & Ext
Do Until Len(Dir$(sNew)) = 0
iX = iX + 1
sNew = path & file & "(" & iX & ")" & Ext
Loop
serialFile = sNew
End Function