Hi All, I have encountered a strangeproblem for which I’m reaching out to this community, hoping that someone canhelp me. I have basic understanding of VBA but I am certainly not an expert.

Anyway, here’s my problem.

I have written a script which allowsme to save attachments from an outlook folder (which I can select) into aWindows Explorer folder (which I can also select). At first glance it seems towork just fine – it ignores email signatures, images etc, and it also changesthe file name in case the file already exists in the Windows explorer folder(nevertheless, if you find flaws in my code please feel free to correct me).For writing this script I used pieces of code I found on the internet (manythanks to everyone who placed them there in the first place).

I have tested my code on a selectionof emails, and all attachments are saved correctly in the correct Explorerfolder. But for some strange reason I cannot understand, some metadata seem tobe modified when running the script. For some of the attachments, the ‘datemodified’ column in Windows explorer is displayed correctly, whilst for othersthe ‘date modified’ column displays the date and time on which the attachmentwas saved (so basically the date and time I ran the code). I tried severaldifferent things, but it does not seem to be related to file type, date of receiptof the email etc. Does anyone know why this happens? And why it happens to someof the attachments and not to others?

Anyway, here is my code:



Sub SaveAttachments()



Dim OL As Outlook.Application
Dim objFolder As Outlook.MAPIFolder

Dim objatmt As Attachment

Dim item As Object

Dim Items As Outlook.Items

Dim strFname As String, strFolder AsString

Dim strExt As String

Dim i As Long

Dim sFolder As String

Dim oShell As Object
Dim ShellApp As Object




Set OL =CreateObject("Outlook.Application")
Set objFolder =OL.GetNamespace("MAPI").GetDefaultFolder(olFolderTasks)

Set objFolder =OL.GetNamespace("MAPI").PickFolder

If TypeName(objFolder) ="Nothing" Then Exit Sub

Debug.Print objFolder.Name


Set ShellApp =CreateObject("Shell.Application"). _

BrowseForFolder(0, "Please choose afolder", 1)

sFolder = ShellApp.self.Path

sFolder = sFolder & ""



If sFolder = "" Then ExitSub



Set Items = objFolder.Items



For Each item In objFolder.Items

On Error Resume Next

If item.Attachments.Count > 0 Then

For i = item.Attachments.Count To 1Step -1

Set objatmt =item.Attachments(i)

If objatmt.Size > 5200 Then

If Not objatmt.FileNameLike "image*.*" Then

strFname =objatmt.FileName

strExt =Right(strFname, Len(strFname) - InStrRev(strFname, Chr(46)))
strFname =FileNameUnique(sFolder, strFname, strExt)

objatmt.SaveAsFilesFolder & strFname

End If

End If

item.Save

Next i

End If

Next

Set objatmt = Nothing

Set item = Nothing

Set ShellApp = Nothing

Set objFolder = Nothing

Set oShell = Nothing

MsgBox ("Done")

End Sub





Private FunctionFileNameUnique(sFolder As String, strFileName As String, strExtension AsString) As String

'An Outlook macro by Graham Mayor

Dim lngF As Long

Dim lngName As Long

lngF = 1

lngName = Len(strFileName) - (Len(strExtension) + 1)

strFileName = Left(strFileName, lngName)

Do While FileExists(sFolder & strFileName & Chr(46) &strExtension) = True

strFileName = Left(strFileName,lngName) & "(" & lngF & ")"

lngF = lngF + 1

Loop

FileNameUnique = strFileName & Chr(46) & strExtension

lbl_Exit:

Exit Function

End Function





Private FunctionFileExists(filespec) As Boolean

'An Outlook macro by Graham Mayor

Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")

If fso.FileExists(filespec) Then

FileExists = True

Else

FileExists = False
End If

lbl_Exit:

Exit Function
End Function


Any help would be most welcome!

Thanks,

Sven