#1
|
|||
|
|||
Saving Outlook folders externally
I am doing projects at the moment and i have a file structure for each one saved on my HDD and i have the same file structure in my outlook. I tried copying the file from Outlook but it wont let me paste it outside of outlook.
It takes ages to copy each e mail and paste it in its corresponding file on my HDD is there a quicker way of doing this? |
#2
|
||||
|
||||
The following outlook macros will save either the selected message or a chosen folder and its subfolders (if any) to the appropriate folders on your local hard drive.
There are a couple of provisos 1. Change strRootPath to the root folder where you wish to save the messages 2. In order to use the 'SaveMessages' macro to process a folder, you will need to download and import the progress Bar userform from the link. Code:
Option Explicit 'Download and import the contents of https://www.gmayor.com/Zips/ProgressBar.zip 'into Outlook's VBA editor to provide the progress bar. Private Const strRootPath As String = "C:\Outlook Message Backup\" 'The folder where the sub folders are stored Sub SaveSelectedMessage() 'Graham Mayor - https://www.gmayor.com - Last updated - 10 Jun 2020 Dim olMsg As MailItem Dim strPath As String, sStore As String On Error Resume Next strPath = strRootPath Do Until Right(strPath, 1) = Chr(92) strPath = strPath & Chr(92) Loop Select Case Outlook.Application.ActiveWindow.Class Case olInspector Set olMsg = ActiveInspector.currentItem Case olExplorer Set olMsg = Application.ActiveExplorer.Selection.Item(1) End Select If TypeName(olMsg) = "MailItem" Then sStore = olMsg.Parent.Store strPath = strPath & olMsg.Parent.FolderPath & Chr(92) strPath = Replace(strPath, "\\" & sStore & "\", "") CreateFolders strPath SaveMessage olMsg, strPath Else MsgBox "No mail item selected" End If lbl_Exit: Exit Sub End Sub Sub SaveMessages() 'Graham Mayor - https://www.gmayor.com - Last updated - 08 May 2019 Dim cFolders As Collection Dim olFolder As Outlook.Folder Dim SubFolder As Outlook.Folder Dim olNS As Outlook.NameSpace Dim strPath As String Dim sSubPath As String Dim sStore As String strPath = strRootPath Do Until Right(strPath, 1) = Chr(92) strPath = strPath & Chr(92) Loop Set cFolders = New Collection Set olNS = GetNamespace("MAPI") 'cFolders.Add olNS.GetDefaultFolder(olFolderInbox) cFolders.Add olNS.PickFolder Do While cFolders.Count > 0 Set olFolder = cFolders(1) cFolders.Remove 1 sStore = olFolder.Store sSubPath = Replace(olFolder.FolderPath, "\\" & sStore & "\", strPath) CreateFolders sSubPath ProcessFolder olFolder, sSubPath If olFolder.folders.Count > 0 Then For Each SubFolder In olFolder.folders cFolders.Add SubFolder Next SubFolder End If Loop lbl_Exit: Set olFolder = Nothing Set SubFolder = Nothing Exit Sub End Sub Private Sub ProcessFolder(olMailFolder As Outlook.Folder, sPath As String) 'Graham Mayor - http://www.gmayor.com Dim olItems As Outlook.items Dim olMailItem As Object Dim i As Long Dim oFrm As New frmProgress Dim PortionDone As Double On Error Resume Next Set olItems = olMailFolder.items oFrm.Show vbModeless i = 0 For Each olMailItem In olItems i = i + 1 If TypeName(olMailItem) = "MailItem" Then 'If Not olMailItem.categories = "Backed-up To File" Then PortionDone = i / olItems.Count oFrm.Caption = olMailFolder.Name & " - Processing " & i & " of " & olItems.Count oFrm.lblProgress.Width = oFrm.fmeProgress.Width * PortionDone SaveMessage olMailItem, sPath 'olMailItem.categories = "Backed-up To File" DoEvents 'End If End If Next olMailItem Unload oFrm lbl_Exit: Set oFrm = Nothing Set olItems = Nothing Set olMailItem = Nothing Exit Sub End Sub Private Sub SaveMessage(olItem As MailItem, sPath As String) 'An Outlook macro by Graham Mayor - www.gmayor.com Dim fname As String fname = Format(olItem.ReceivedTime, "yyyymmdd") & Chr(32) & _ Format(olItem.ReceivedTime, "HH.MM") & " - " & 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, sPath, fname lbl_Exit: Exit Sub End Sub Private Function SaveUnique(oItem As Object, _ strPath As String, _ strFileName As String) 'An Outlook macro by Graham Mayor - www.gmayor.com Dim lngF As Long Dim lngName As Long Dim oFSO As Object Set oFSO = CreateObject("Scripting.FileSystemObject") lngF = 1 lngName = Len(strFileName) Do While oFSO.FileExists(strPath & strFileName & ".msg") = True strFileName = Left(strFileName, lngName) & "(" & lngF & ")" lngF = lngF + 1 Loop oItem.SaveAs strPath & strFileName & ".msg" lbl_Exit: Set oFSO = Nothing Exit Function End Function Private Function CreateFolders(strPath As String) 'An Office macro by Graham Mayor - www.gmayor.com Dim strTempPath As String Dim lngPath As Long Dim VPath As Variant Dim oFSO As Object Set oFSO = CreateObject("Scripting.FileSystemObject") VPath = Split(strPath, "\") strPath = VPath(0) & "\" For lngPath = 1 To UBound(VPath) strPath = strPath & VPath(lngPath) & "\" If Not oFSO.FolderExists(strPath) Then MkDir strPath Next lngPath lbl_Exit: Set oFSO = Nothing 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 |
How to place an externally linked video while keeping formatting functionality | beachparty | PowerPoint | 1 | 12-09-2017 06:42 AM |
Saving email folders to text file | cnjones45 | Outlook | 0 | 12-01-2016 07:55 PM |
How do I add a CC to an externally generated Email ? | vodkasoda | Outlook | 8 | 01-26-2016 02:50 PM |
how to synchronize emails in certain folders when upgrade Outlook 2010 to Outlook 201 | davip | Outlook | 0 | 07-30-2013 09:07 PM |
How to re-link default email acct folders to default Outlook Data File folders? | RDA1959 | Outlook | 0 | 03-26-2012 10:55 AM |