#1
|
|||
|
|||
Saving Outlook messages
Hi, I'm new to the forum and hoping someone can help me with my question. I have technical job and I get many emails over time (going back many years) that have relevance every now. However, my company decided the were going to delete email that are before a certain date. I've looked around at ways to try to save these emails, but I can't seem to get one to work. From what I can tell, they've disabled exporting, personal folders, and if you try to move emails to a different account, it complains something not be able to access the server. These are helpful emails, but I'm sure I'm in the minority of the company that needs to keep these. There's a lot of emails so it's not practical to just forward them to another external email address. I was hoping to find a way to save them in a batch. Thanks for your time. |
#2
|
||||
|
||||
The following macro should work to save the messages to your hard drive as separate uniquely named msg files. The named folder will be created if it doesn't already exist. Select the messages you want to save and run the 'SaveSelectedMessages' macro:
Code:
Sub SaveSelectedMessages() Dim i As Long Dim olItem As MailItem i = 0 For Each olItem In Application.ActiveExplorer.Selection If olItem.Class = OlObjectClass.olMail Then i = i + 1 SaveMessage olItem End If Next olItem MsgBox "Processing complete" & vbCr & i & " messages saved." Set olItem = Nothing lbl_Exit: Exit Sub End Sub Private Sub SaveMessage(olItem As MailItem) Dim Fname As String Dim fPath As String fPath = "C:\Path\EMail Backup\" 'The hard drive path where you wish to save the messages CreateFolders fPath Fname = Format(olItem.ReceivedTime, "yyyymmdd") & Chr(32) & _ Format(olItem.ReceivedTime, "HH.MM") & Chr(32) & olItem.SenderName & " - " & olItem.Subject Fname = Replace(Fname, Chr(58) & Chr(41), "") Fname = Replace(Fname, Chr(58) & Chr(40), "") Fname = Replace(Fname, Chr(34), "-") Fname = Replace(Fname, Chr(42), "-") Fname = Replace(Fname, Chr(47), "-") Fname = Replace(Fname, Chr(58), "-") Fname = Replace(Fname, Chr(60), "-") Fname = Replace(Fname, Chr(62), "-") Fname = Replace(Fname, Chr(63), "-") Fname = Replace(Fname, Chr(124), "-") SaveUnique olItem, fPath, Fname lbl_Exit: Exit Sub End Sub Private Function SaveUnique(oItem As Object, _ strPath As String, _ strFileName As String) Dim lngF As Long Dim lngName As Long lngF = 1 lngName = Len(strFileName) Do While FileExists(strPath & strFileName & ".msg") = True strFileName = Left(strFileName, lngName) & "(" & lngF & ")" lngF = lngF + 1 Loop oItem.SaveAs strPath & strFileName & ".msg" lbl_Exit: Exit Function End Function Private Function FileExists(filespec) As Boolean 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 Private Function FolderExists(fldr) As Boolean 'An Outlook macro by Graham Mayor Dim fso As Object Set fso = CreateObject("Scripting.FileSystemObject") If (fso.FolderExists(fldr)) Then FolderExists = True Else FolderExists = False End If lbl_Exit: Exit Function End Function Private Function CreateFolders(strPath As String) 'An Outlook macro by Graham Mayor Dim strTempPath As String Dim lngPath As Long Dim vPath As Variant vPath = Split(strPath, "\") strPath = vPath(0) & "\" For lngPath = 1 To UBound(vPath) strPath = strPath & vPath(lngPath) & "\" If Not FolderExists(strPath) Then MkDir strPath Next lngPath lbl_Exit: Exit Function End Function
__________________
Graham Mayor - MS MVP (Word) (2002-2019) Visit my web site for more programming tips and ready made processes www.gmayor.com |
|
Similar Threads | ||||
Thread | Thread Starter | Forum | Replies | Last Post |
Saving Outlook Messages Locally | damsh | Excel | 2 | 09-30-2011 08:33 AM |
Outlook Messages | AnGeLdEaD | Outlook | 2 | 01-18-2011 11:40 PM |
Outlook Deleted Messages | NS1981 | Outlook | 2 | 07-19-2010 06:25 AM |
outlook retrieve messages...... | ranjit_dutt | Outlook | 0 | 06-19-2010 07:35 AM |