Microsoft Office Forums

Go Back   Microsoft Office Forums > >

Reply
 
Thread Tools Display Modes
  #1  
Old 06-09-2020, 03:40 AM
Oillybob Oillybob is offline Saving Outlook folders externally Windows 8 Saving Outlook folders externally Office 2013
Novice
Saving Outlook folders externally
 
Join Date: Apr 2017
Posts: 2
Oillybob is on a distinguished road
Default 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?
Reply With Quote
  #2  
Old 06-10-2020, 01:34 AM
gmayor's Avatar
gmayor gmayor is offline Saving Outlook folders externally Windows 10 Saving Outlook folders externally Office 2016
Expert
 
Join Date: Aug 2014
Posts: 3,189
gmayor is a glorious beacon of lightgmayor is a glorious beacon of lightgmayor is a glorious beacon of lightgmayor is a glorious beacon of lightgmayor is a glorious beacon of lightgmayor is a glorious beacon of light
Default

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
Reply With Quote
Reply

Thread Tools
Display Modes


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

Other Forums: Access Forums - Senior Forums

All times are GMT -7. The time now is 02:05 AM.


Powered by vBulletin® Version 3.8.11
Copyright ©2000 - 2020, vBulletin Solutions Inc.
Search Engine Optimisation provided by DragonByte SEO (Lite) - vBulletin Mods & Addons Copyright © 2020 DragonByte Technologies Ltd.
MSOfficeForums.com is not affiliated with Microsoft