outlook VBA code for saving attachments to folder seems to change metadata sometimes
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
