Move Selected emails to Local Drive


Outlook version
Outlook 365 32 bit
Email Account
Office 365 Exchange
Operating system::    Windows 10
Outlook version:     Outlook 365
Email type or host:    Microsoft 365

Hello all! Hope someone can help a bit. I receive about 100 emails on a regular basis from a customer. I need to save these selected emails into a folder on my local Hard Drive with the current date. I have found a code that appears it would do what I need, but unfortunately, the pinned folder does not show when I open and browse the folders. It also bombs out with error code 76 after creating a folder.

My goal would be to create a folder on the HD and actually "MOVE" the selected emails (I could even specify the sender if it would be easier) using vba. Below is the code I am working with that I found on another site. Any assistance would be most appreciated!! Thanks as always!

Option Explicit
Sub SaveAllEmails_ProcessAllSubFolders()
    Dim i               As Long
    Dim j               As Long
    Dim n               As Long
    Dim StrSubject      As String
    Dim StrName         As String
    Dim StrFile         As String
    Dim StrReceived     As String
    Dim StrSavePath     As String
    Dim StrFolder       As String
    Dim StrFolderPath   As String
    Dim StrSaveFolder   As String
    Dim Prompt          As String
    Dim Title           As String
    Dim iNameSpace      As NameSpace
    Dim myOlApp         As Outlook.Application
    Dim SubFolder       As MAPIFolder
    Dim mItem           As MailItem
    Dim FSO             As Object
    Dim ChosenFolder    As Object
    Dim Folders         As New Collection
    Dim EntryID         As New Collection
    Dim StoreID         As New Collection
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set myOlApp = Outlook.Application
    Set iNameSpace = myOlApp.GetNamespace("MAPI")
    Set ChosenFolder = iNameSpace.PickFolder
    If ChosenFolder Is Nothing Then
GoTo ExitSub:
    End If
    Prompt = "Please enter the path to save all the emails to."
    Title = "Folder Specification"
    StrSavePath = BrowseForFolder
    If StrSavePath = "" Then
GoTo ExitSub:
    End If
    If Not Right(StrSavePath, 1) = "\" Then
        StrSavePath = StrSavePath & "\"
    End If
    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 = ArrangedDate(mItem.ReceivedTime)
            StrSubject = mItem.Subject
            StrName = StripIllegalChar(StrSubject)
            StrFile = StrSaveFolder & StrReceived & "_" & StrName & ".msg"
            StrFile = Left(StrFile, 256)
            mItem.SaveAs StrFile, 3
        Next j
        On Error GoTo 0
    Next i
End Sub
Function StripIllegalChar(StrInput)
    Dim RegX            As Object
    Set RegX = CreateObject("vbscript.regexp")
    RegX.Pattern = "[\" & Chr(34) & "\!\@\#\$\%\^\&\*\(\)\=\+\|\[\]\{\}\`\'\;\:\<\>\?\/\,]"
    RegX.IgnoreCase = True
    RegX.Global = True
    StripIllegalChar = RegX.Replace(StrInput, "")
    Set RegX = Nothing
End Function
Function ArrangedDate(StrDateInput)
    Dim StrFullDate     As String
    Dim StrFullTime     As String
    Dim StrAMPM         As String
    Dim StrTime         As String
    Dim StrYear         As String
    Dim StrMonthDay     As String
    Dim StrMonth        As String
    Dim StrDay          As String
    Dim StrDate         As String
    Dim StrDateTime     As String
    Dim RegX            As Object
    Set RegX = CreateObject("vbscript.regexp")
    If Not Left(StrDateInput, 2) = "10" And _
    Not Left(StrDateInput, 2) = "11" And _
    Not Left(StrDateInput, 2) = "12" Then
        StrDateInput = "0" & StrDateInput
    End If
    StrFullDate = Left(StrDateInput, 10)
    If Right(StrFullDate, 1) = " " Then
        StrFullDate = Left(StrDateInput, 9)
    End If
    StrFullTime = Replace(StrDateInput, StrFullDate & " ", "")
    If Len(StrFullTime) = 10 Then
        StrFullTime = "0" & StrFullTime
    End If
    StrAMPM = Right(StrFullTime, 2)
    StrTime = StrAMPM & "-" & Left(StrFullTime, 8)
    StrYear = Right(StrFullDate, 4)
    StrMonthDay = Replace(StrFullDate, "/" & StrYear, "")
    StrMonth = Left(StrMonthDay, 2)
    StrDay = Right(StrMonthDay, Len(StrMonthDay) - 3)
    If Len(StrDay) = 1 Then
        StrDay = "0" & StrDay
    End If
    StrDate = StrYear & "-" & StrMonth & "-" & StrDay
    StrDateTime = StrDate & "_" & StrTime
    RegX.Pattern = "[\:\/\ ]"
    RegX.IgnoreCase = True
    RegX.Global = True
    ArrangedDate = RegX.Replace(StrDateTime, "-")
    Set RegX = Nothing
End Function
Sub GetFolder(Folders As Collection, EntryID As Collection, StoreID As Collection, Fld As MAPIFolder)
    Dim SubFolder       As MAPIFolder
    Folders.Add Fld.FolderPath
    EntryID.Add Fld.EntryID
    StoreID.Add Fld.StoreID
    For Each SubFolder In Fld.Folders
        GetFolder Folders, EntryID, StoreID, SubFolder
    Next SubFolder
    Set SubFolder = Nothing
End Sub
Function BrowseForFolder(Optional OpenAt As String) As String
    Dim ShellApp As Object
    Set ShellApp = CreateObject("Shell.Application"). _
    BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
    On Error Resume Next
    BrowseForFolder = ShellApp.self.Path
    On Error GoTo 0
    Select Case Mid(BrowseForFolder, 2, 1)
    Case Is = ":"
        If Left(BrowseForFolder, 1) = ":" Then
            BrowseForFolder = ""
        End If
    Case Is = "\"
        If Not Left(BrowseForFolder, 1) = "\" Then
            BrowseForFolder = ""
        End If
    Case Else
        BrowseForFolder = ""
    End Select
    Set ShellApp = Nothing
End Function
Similar threads
Thread starter Title Forum Replies Date
B Macro to manually move selected emails to network folder Outlook VBA and Custom Forms 1
S Macro to print & move selected emails? Using Outlook 3
O On click,I want to change subject line of selected mail and then reply to particular email and move Using Outlook 3
M code to move selected Outlook contacts to another folder Using Outlook 3
A Search folder and move the email Outlook VBA and Custom Forms 0
A Outlook 365 (OutLook For Mac)Move "On My Computer" Folder Items From Old To New Mac Computer Using Outlook 3
HarvMan Outlook 365 - Rule to Move an Incoming Message to Another Folder Using Outlook 4
humility36 Cannot move emails to archive - 440 error Outlook VBA and Custom Forms 1
B Outlook 2019 Automatically move email after assigning category Using Outlook 4
C Trying to move messages between imap accounts/folders Using Outlook 5
M Move command Outlook VBA and Custom Forms 11
C Code to move mail with certain attachment name? Does Not work Outlook VBA and Custom Forms 3
B Move emails from one account to another Outlook VBA and Custom Forms 2
J Quick steps delete original email and move reply/sent email to folder Using Outlook 2
N How to add or delete items to Move dropdown Menu Using Outlook 0
Commodore Unable to move message Using Outlook 3
N Line to move origEmail to subfolder within a reply macro Outlook VBA and Custom Forms 0
C Move or copy from field to field Outlook VBA and Custom Forms 0
T Outlook 365 Move newly created tasks automatically on save. Outlook VBA and Custom Forms 1
NVDon Create new Move To Folder list Outlook VBA and Custom Forms 0
P Print attachments automatically and move the mail to an existing folder called "Ted" Outlook VBA and Custom Forms 4
T Macro to move reply and original message to folder Outlook VBA and Custom Forms 6
F VBA to move email from Non Default folder to Sub folders as per details given in excel file Outlook VBA and Custom Forms 11
F Excel VBA to move mails for outlook 365 on secondary mail account Outlook VBA and Custom Forms 1
J Dopey move - deleted profile Using Outlook 1
GregS Outlook 2016 Move Outlook to new computer? Using Outlook 4
Witzker Macro to move @domain.xx of a Spammail to Blacklist in Outlook 2019 Outlook VBA and Custom Forms 7
G Move tasks up/down todo list by VBA Outlook VBA and Custom Forms 1
S Macro to move “Re:” & “FWD:” email recieved the shared inbox to a subfolder in outlook Outlook VBA and Custom Forms 0
S Outlook Macro to move reply mail based on the key word in the subjectline Outlook VBA and Custom Forms 0
D Move Email with Attachment to Folder Outlook VBA and Custom Forms 3
Eike Move mails via macro triggered by the click of a button? Outlook VBA and Custom Forms 0
G Cannot Move Autocomplete File to New Computer Using Outlook 15
M Move to Folder Using Outlook 1
P Move emails between 2 mailboxes. Using Outlook 0
C Copy Move item won't work Outlook VBA and Custom Forms 2
N Macro to move all recipients to CC while replying Outlook VBA and Custom Forms 0
Commodore Move turns into "copy" Using Outlook 3
R List folders in a combo box + select folder + move emails from inbox to that folder + reply to that email Outlook VBA and Custom Forms 1
Jennifer Murphy Ctrl+Tab sometimes will not move through text a word at a time Using Outlook 1
V Outlook 2016 will not move emails in search results Using Outlook 4
M move to iCloud not working in outlook calendar Using Outlook 12
A Create date folder and move messages daily Outlook VBA and Custom Forms 1
Commodore Folders always closed in move/copy items dialog box Using Outlook 3
C Move Outlook 2007 to new PC with Outlook 365 Using Outlook 3
C Can't move folder, the folder is full Using Outlook 0
Nadine Rule to move attachments with specific name Outlook VBA and Custom Forms 1
A Move email items based on a list of email addresses Outlook VBA and Custom Forms 40
T Move calendar invites to new calendar Using Outlook 5
O Rule to move (specific) messages from Sent folder to Specific folder Using Outlook 1

Similar threads