Consulting

Results 1 to 2 of 2

Thread: Save selected messages VBA does not save replied messages

  1. #1

    Save selected messages VBA does not save replied messages

    Hi all,

    So please see the VBA code i'm using to save selected messages to a folder of my choice. I noticed that whenever i try to save responded mails, it fails to save as an .eml file and just turns into a blank file (attached image). Please see code below, what am I doing wrong? This is really giving me stress.

    Public Sub SaveMessageAsMsg()
    'Update by Extendoffice 2018/3/5
    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
    Attached Images Attached Images

  2. #2
    You need a different approach for messages you have sent (and more care with declaring variables). I have posted the following previously
    Option Explicit
    'Graham Mayor - https://www.gmayor.com - Last updated - 20 Mar 2021 
    Sub SaveSelectedMessagesAsMsg()
    'An Outlook macro by Graham Mayor - www.gmayor.com
    'Saves the currently selected messages
    Dim sPath As String
    Dim olItem As MailItem
        sPath = BrowseForFolder
        If sPath = "" Then
            Beep
            GoTo lbl_Exit
        End If
        Do Until Right(sPath, 1) = Chr(92)
            sPath = sPath & Chr(92)
        Loop
        For Each olItem In Application.ActiveExplorer.Selection
            If olItem.Class = OlObjectClass.olMail Then
                SaveItem olItem, sPath
            End If
        Next olItem
        MsgBox "Message(s) saved", vbInformation
    lbl_Exit:
        Set olItem = Nothing
        Exit Sub
    End Sub
    
    
    Private Sub SaveItem(olItem As MailItem, strPath As String)
    'An Outlook macro by Graham Mayor - www.gmayor.com
    'The main macro called by the above macros.
    'This macro can be used as a script to save the messages as they arrive
    'provided you change fPath = to a fixed path, so you are not prompted each time a message arrives
    Dim fname As String
    If olItem.sender Like "*@gmayor.com" Then    'Your domain
            fname = Format(olItem.SentOn, "yyyymmdd") & Chr(32) & _
                    Format(olItem.SentOn, "HH.MM") & Chr(32) & olItem.SenderName & " - " & olItem.Subject
        Else
            fname = Format(olItem.ReceivedTime, "yyyymmdd") & Chr(32) & _
                    Format(olItem.ReceivedTime, "HH.MM") & Chr(32) & olItem.SenderName & " - " & olItem.Subject
        End If
        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(92), "-")
        fname = Replace(fname, Chr(124), "-")
        On Error GoTo err_Handler
        SaveUnique olItem, strPath, fname
    lbl_Exit:
        Exit Sub
    err_Handler:
        Err.Clear
        GoTo lbl_Exit
    End Sub
    
    
    Private Function SaveUnique(oItem As Object, _
                                strPath As String, _
                                strFileName As String)
    'An Outlook macro by Graham Mayor - www.gmayor.com
    'Ensures that filenames are not overwritten
    Dim lngF As Long
    Dim lngName As Long
    Dim FSO As Object
        Set FSO = CreateObject("Scripting.FileSystemObject")
        lngF = 1
        lngName = Len(strFileName)
        Do While FSO.FileExists(strPath & strFileName & ".msg") = True
            strFileName = Left(strFileName, lngName) & "(" & lngF & ")"
            lngF = lngF + 1
        Loop
        oItem.SaveAs strPath & strFileName & ".msg" '".txt", olTXT
    lbl_Exit:
        Exit Function
    End Function
    
    
    Private Function BrowseForFolder() As String
    Dim FSO As Object
        Set FSO = CreateObject("Shell.Application"). _
                       BrowseForFolder(0, "Please choose the folder to save the messaage(s)", 0)
        On Error Resume Next
        BrowseForFolder = FSO.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
    lbl_Exit:
        Set FSO = Nothing
        Exit Function
    End Function
    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
  •