Consulting

Results 1 to 4 of 4

Thread: Saving Multiple Selected Emails As MSG Files In Bulk In Outlook

  1. #1

    Smile Saving Multiple Selected Emails As MSG Files In Bulk In Outlook

    Hi all. I am trying to figure out a VBA code for saving multiple selected emails with the the subject :"date" & "time" & "original subject".

    I am using this code.

    Public Sub SaveMessageAsMsg()
    Dim xMail As Outlook.MailItem
    Dim xObjItem As Object
    Dim xPath As String
    Dim xDtDate As Date
    Dim xName, xFileName As String
    On Error Resume Next
    Set xShell = CreateObject("Shell.Application")
    Set xFolder = xShell.BrowseForFolder(0, "Select a folder:", 0, strStartingFolder)
    If Not TypeName(xFolder) = "Nothing" Then
    Set xFolderItem = xFolder.self
    xFileName = xFolderItem.Path & ""
    Else
    xFileName = ""
    Exit Sub
    End If
    For Each xObjItem In Outlook.ActiveExplorer.Selection
    If xObjItem.Class = olMail Then
    Set xMail = xObjItem
    xName = xMail.Subject
    xDtDate = xMail.ReceivedTime
    xName = Format(xDtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
    vbUseSystem) & Format(xDtDate, "-hhnnss", _
    vbUseSystemDayOfWeek, vbUseSystem) & "-" & xName & ".msg"
    xPath = xFileName + xName
    xMail.SaveAs xPath, olMSG
    End If
    Next
    End Sub



    The problem is that window does not allow file name with "","/",":","*","?",""","<",">" and "|"
    So, the above code does not apply to subject with those symbol.
    How can I replace those symbol with blank to save my email messages?

  2. #2
    VBAX Mentor skatonni's Avatar
    Joined
    Jun 2006
    Posts
    347
    Location
    There are multiple method available for example.

    Option Explicit
    
    Public Sub SaveMessageAsMsg()
    
        Dim xShell As Object
        Dim xFolder As Object
        Dim strStartingFolder As String
        Dim xFolderItem As Object
        
        Dim xMail As MailItem
        Dim xObjItem As Object
        
        Dim xPath As String
        Dim xFileName As String
        Dim xName As String
        Dim xDtDate As Date
        
        Set xShell = CreateObject("Shell.Application")
    
        On Error Resume Next
        ' Bypass error when xFolder is nothing on Cancel
        Set xFolder = xShell.BrowseForFolder(0, "Select a folder:", 0, strStartingFolder)
        ' Remove error bypass as soon as the purpose is served
        On Error GoTo 0
        
        If Not TypeName(xFolder) = "Nothing" Then
            Set xFolderItem = xFolder.Self
            xFileName = xFolderItem.path
            ' missing path separator
            If Right(xFileName, 1) <> "\" Then xFileName = xFileName & "\"
        Else
            xFileName = ""
            Exit Sub
        End If
        
        For Each xObjItem In ActiveExplorer.Selection
        
            If xObjItem.Class = olmail Then
            
                Set xMail = xObjItem
                
                xName = CleanFileName(xMail.Subject)
                Debug.Print xName
                
                xDtDate = xMail.ReceivedTime
                
                xName = Format(xDtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
                  vbUseSystem) & Format(xDtDate, "-hhnnss", _
                  vbUseSystemDayOfWeek, vbUseSystem) & "-" & xName & ".msg"
                
                xPath = xFileName & xName
                
                xMail.SaveAs xPath, olMsg
            End If
        Next
        
    End Sub
    
    Public Function CleanFileName(strFileName As String) As String
    
        ' http://windowssecrets.com/forums/sho...Charaters-(VBA)
        
        Dim Invalids
        Dim e
        Dim strTemp As String
        
        Invalids = Array("?", "*", ":", "|", "<", ">", "[", "]", """", "/")
        
        strTemp = strFileName
        
        For Each e In Invalids
            strTemp = Replace(strTemp, e, " ")
            'strTemp = Replace(strTemp, e, "")
        Next
        
        CleanFileName = strTemp
        
    End Function
    To debug, mouse-click anywhere in the code. Press F8 repeatedly to step through the code. http://www.cpearson.com/excel/DebuggingVBA.aspx

    If your problem has been solved in your thread, mark the thread "Solved" by going to the "Thread Tools" dropdown at the top of the thread. You might also consider rating the thread by going to the "Rate Thread" dropdown.

  3. #3
    Thank you so much, it is very helpful for me.
    However, I encounter another problem.
    If the subject is too long, the code will be failed to save to email. Is there any way to cut the excess words?

  4. #4
    You can use the Left function to limit the number of characters e.g.

    change
    xName = CleanFileName(xMail.Subject)
    to
    xName = Left(CleanFileName(xMail.Subject),100)
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •