Save Emails From Outlook To Hard Drive

[tsarms]

Good afternoon all,

I found the following on vbax which works fine in Outlook 2010:

Sorry, can't post links as this is my first post: vbaexpress.com/kb/getarticle.php?kb_id=875#instr

The code does exactly what it says on the tin: selects the outlook folder to be saved, then selects the drive (or network drive) to be saved to..

My issue is the resultant .msg has a load of numbers and hyphens added at the beginning of the filename (ie"-201-00--11-201_05-004-11-2_Original email subject")

Can anyone please show me where in the coding this is being generated from and how I can change it to just add the date stamp of the email in the format "YYYYMMDD_"

Many thanks in advance

T

[skatonni]

I am sure there was a reason for ArrangedDate but replacing it does not appear to cause a problem.

Instead of
StrReceived = ArrangedDate(mItem.ReceivedTime)

try
StrReceived = Format(mItem.ReceivedTime, "yyyymmdd")

[tsarms]

Thanks skatonni, that did the trick perfectly,

Would have been looking at that for hours without working it out.

[tsarms]

Hi all,

Not sure if I am permitted to do this, but I have re-opened this thread to make an additional query.....

I have added the time to the end of Skatonni's code (yyyymmdd_hhnnss) because if multiple messages in the same thread [ie all with the same Subject title] were sent/received in the same day, only one of them would be saved. I have seen a few codes to add a numerical addition to the end of the filename (1) like Windows does with duplicates, but can't get any of them to work in this instance.

As a side note, say if I wanted to delete the original messages from Outlook after having saved them to disk.....any thoughts?

Thanks again

T

[skatonni]

I have added the time to the end of Skatonni's code (yyyymmdd_hhnnss) because if multiple messages in the same thread [ie all with the same Subject title] were sent/received in the same day, only one of them would be saved. I have seen a few codes to add a numerical addition to the end of the filename (1) like Windows does with duplicates, but can't get any of them to work in this instance.

Since you did not indicate what you did, you could have already tried these ideas.
http://www.vbaexpress.com/forum/showthread.php?32499-Auto-saving-files-and-renaming-file-name-Genius-needed

[tsarms]

Sorry; I have inserted this function into the code below where the naming and saving takes place, but duplicate messages will only save once. Can you see where I have gone wrong?


Call GetFolder(Folders, EntryID, StoreID, ChosenFolder)

For i = 1 To Folders.Count
StrFolder = StripIllegalChar(Folders(i))
n = InStr(3, StrFolder, "\") + 1
StrFolder = Mid(StrFolder, n, 256)
StrFolderPath = StrSavePath & StrFolder & "\"
StrSaveFolder = Left(StrFolderPath, Len(StrFolderPath) - 1) & "\"
If Not FSO.FolderExists(StrFolderPath) Then
FSO.CreateFolder (StrFolderPath)
End If

Set SubFolder = myOlApp.Session.GetFolderFromID(EntryID(i), StoreID(i))
On Error Resume Next
For j = 1 To SubFolder.Items.Count
Set mItem = SubFolder.Items(j)
StrReceived = Format(mItem.ReceivedTime, "yyyymmdd_")
StrSubject = mItem.Subject
StrName = StripIllegalChar(StrSubject)
StrFile = StrSaveFolder & StrReceived & "_" & StrName & ".msg"
StrFile = Left(StrFile, 256)

If StrFile = "" Then
mItem.SaveAsFile StrFile
Else
i = i + 1

End If

mItem.SaveAs StrFile, 3
Next j
On Error GoTo 0
Next i

ExitSub:

[skatonni]

It looks like you are trying to incorporate something from http://www.vbaexpress.com/forum/showthread.php?32499-Auto-saving-files-and-renaming-file-name-Genius-needed:


i = 0
JumpHere:
If Dir(stFileName) = "" then
objAtt.SaveAsFile stFileName
else
i=i+1
stFileName = saveFolder & "\" & i & " - " & objAtt.DisplayName
goto Jumphere
end if


Try this untested code.


For i = 1 To Folders.Count
StrFolder = StripIllegalChar(Folders(i))
n = InStr(3, StrFolder, "\") + 1
StrFolder = Mid(StrFolder, n, 256)
StrFolderPath = StrSavePath & StrFolder & "\"
StrSaveFolder = Left(StrFolderPath, Len(StrFolderPath) - 1) & "\"

If Not FSO.FolderExists(StrFolderPath) Then
FSO.CreateFolder (StrFolderPath)
End If

Set SubFolder = myOlApp.Session.GetFolderFromID(EntryID(i), StoreID(i))
' On Error Resume Next ' <-- I suggest you comment this out when debugging
For j = 1 To SubFolder.Items.Count
Set mItem = SubFolder.Items(j)
StrReceived = ArrangedDate(mItem.ReceivedTime)
StrSubject = mItem.Subject
StrName = StripIllegalChar(StrSubject)

' StrFile = StrSaveFolder & StrReceived & "_" & StrName & ".msg"
' StrFile = Left(StrFile, 256)

StrFile = Left(StrSaveFolder & StrReceived & "_" & StrName, 251) & ".msg"

k = 0 ' <--- i is already being used
JumpHere:
If Dir(StrFile) = "" then
mItem.SaveAs StrFile, 3
else
k=k+1
StrFile = Left(StrSaveFolder & StrReceived & "_" & StrName, 251) & k & ".msg"
goto Jumphere
end if

mItem.SaveAs StrFile, 3
Next j
On Error Goto 0
Next i

[tsarms]

Thanks skatonni, after adding the change you suggested earlier at post 2 to your latest code, it now works as it should do. All messages saved are renamed with the date prefixed to the subject title and if duplicated a numeric added to the end - exactly what I was trying to get (completely overlooked i being used already).

To delete the message after it is saved to file I have used 'mItem.delete' at the end of the statement
Else
k=k+1
StrFile = Left(StrSaveFolder & StrReceived & "_" & StrName, 251) & k & ".msg"
Goto Jumphere
End If

mItem.SaveAs StrFile, 3
mItem.Delete
Next j
On Error Goto 0
Next i

This works to a certain degree: the code will now only save and delete exactly 50% of the mailbox at a time - eg if 38 items in mailbox, 19 are saved to file and deleted from mailbox; run the macro again and this time 9 of the remaining 19 are saved and deleted and so on.
If I remove the mItem.Delete all items in the mailbox are saved! I can't see any Max statement in the code or anything that would prevent ALL items from being saved and then deleted in one go??

[skatonni]

http://www.vbaexpress.com/forum/showthread.php?45790-Won-t-loop-though-Email-Items


For j = SubFolder.Items.Count To 1 Step -1



mItem.Delete
Next j

[tsarms]

Easy as that! Thanks Skatonni all working now

[rantanplan]

Hi, thanks skatonni and tsarms for your contributions that helped me a lot with this code. I'm not sure however why only inbox folders can be processed and not teir individual subfolders. Is there a way to adjust the code so also inbox subfolders can be saved to a hard drive? Thanks