Macro to save selected emails of Outlook in Windows folder

Question

I am trying to save outlook emails to windows folder, but the macro which i had is not working properly, at each email save it opens browse window,

it should save all the selected mails to a browse folder at a time

Option Explicit

Function BrowseForFolder(Optional OpenAt As Variant) As Variant
  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

 Set ShellApp = Nothing
    Select Case Mid(BrowseForFolder, 2, 1)
        Case Is = ":"
            If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
        Case Is = "\"
            If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
        Case Else
            GoTo Invalid
    End Select
 Exit Function

Invalid:
 BrowseForFolder = False
End Function


Public Sub SaveMessageAsMsg()
  Dim oMail As Outlook.MailItem
  Dim objItem As Object
  Dim sPath, strFolderpath As String
  Dim dtDate As Date
  Dim sName As String
  Dim enviro As String

    enviro = CStr(Environ("USERPROFILE"))
   For Each objItem In ActiveExplorer.Selection
   If objItem.MessageClass = "IPM.Note" Then
    Set oMail = objItem

  sName = oMail.Subject
  ReplaceCharsForFileName sName, "-"

  dtDate = oMail.ReceivedTime
  sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
    vbUseSystem) & Format(dtDate, "-hhnnss", _
    vbUseSystemDayOfWeek, vbUseSystem) & "-" & sName & ".msg"



  strFolderpath = BrowseForFolder("D:\test\mails\")
  sPath = strFolderpath & "\"
  Debug.Print sPath & sName
  oMail.SaveAs sPath & sName, olMSG

  End If
  Next

End Sub

Private Sub ReplaceCharsForFileName(sName As String, _
  sChr As String _
)
  sName = Replace(sName, "'", sChr)
  sName = Replace(sName, "*", sChr)
  sName = Replace(sName, "/", sChr)
  sName = Replace(sName, "\", sChr)
  sName = Replace(sName, ":", sChr)
  sName = Replace(sName, "?", sChr)
  sName = Replace(sName, Chr(34), sChr)
  sName = Replace(sName, "<", sChr)
  sName = Replace(sName, ">", sChr)
  sName = Replace(sName, "|", sChr)
End Sub

Hi Vino you should check out the wonderful answer by siddharth to see if the answer helps. http://stackoverflow.com/questions/11781320/download-attachment-from-outlook-and-open-in-excel I think your issue is slightly different but it could be helpful — jamesC, Feb 12 '15 at 14:10

score 3 · Accepted Answer · answered Feb 13 '15 at 10:57

Move BrowseForFolder outside of the loop

Public Sub SaveMessageAsMsg()
    Dim oMail As Outlook.MailItem
    Dim objItem As Object
    Dim sPath, strFolderpath As String
    Dim dtDate As Date
    Dim sName As String
    Dim enviro As String

    enviro = CStr(Environ("USERPROFILE"))

    strFolderpath = BrowseForFolder("D:\test\mails\")
    sPath = strFolderpath & "\"

    For Each objItem In ActiveExplorer.Selection
        If objItem.MessageClass = "IPM.Note" Then
            Set oMail = objItem    
            sName = oMail.Subject
            ReplaceCharsForFileName sName, "-"  
            dtDate = oMail.ReceivedTime
            sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
              vbUseSystem) & Format(dtDate, "-hhnnss", _
              vbUseSystemDayOfWeek, vbUseSystem) & "-" & sName & ".msg"      
            Debug.Print sPath & sName
            oMail.SaveAs sPath & sName, olMSG   
         End If
    Next
End Sub

score 0 · Answer 2 · answered Feb 12 '15 at 14:13

0

The BrowseForFolder method shows the dialog for choosing the folder. You need to hard code the path instead of calling the function for choosing the folder. The SaveAs method of Outlook items doesn't display any dialogs.

answered Feb 12 '15 at 14:13

Eugene Astafiev

26,795
2
13
31

Hi , Thanks for the answer, actually the issue is if i hard code the path than for different mails i will have to change path again and again. Have already differentiated mails in particular folders in outlook so i am selecting those mails to save in windows folder with the same folder. So to over come this I had added browse function but at each mail it pop ups – Vino Feb 12 '15 at 14:55
Where is the issue then? – Eugene Astafiev Feb 12 '15 at 15:00
issue is it pop ups at each save email, it should save all the selected mails than there should be an pop up, – Vino Feb 13 '15 at 04:19
What "it pop ups" are you talking about? – Eugene Astafiev Feb 13 '15 at 09:04

Macro to save selected emails of Outlook in Windows folder

2 Answers2

Linked