Dialog called up multiple times when saving emails from macro

Status
Not open for further replies.

Izbi

New Member
Outlook version
Outlook 2007
Email Account
This macro saves selected emails into a folder chosen by function "BrowseForFolder". If I select "n" emails to save, the dialog comes up "n" times. Is there a way to call it up just once?

Code:
Option Explicit

Public Sub Save_Messages_Select_Ask2()

Dim oMail As Outlook.MailItem
Dim objItem As Object
Dim sPath 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

dtDate = oMail.ReceivedTime
sName = Format(dtDate, "yyyy mm dd", vbUseSystemDayOfWeek, _
vbUseSystem) & Format(dtDate, " hhnn", _
vbUseSystemDayOfWeek, vbUseSystem) & " - " & sName & ".msg"

sPath = BrowseForFolder(enviro & "\Documents\")
Debug.Print sPath & "\" & sName
oMail.SaveAs sPath & "\" & sName, olMSG

End If
Next

End Sub

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
 

Diane Poremsky

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
it's inside the loop -
For Each objItem In ActiveExplorer.Selection
next

move it above the loop.


Code:
sPath = BrowseForFolder(enviro & "\Documents\")


For Each objItem In ActiveExplorer.Selection

If objItem.MessageClass = "IPM.Note" Then
Set oMail = objItem

sName = oMail.Subject

dtDate = oMail.ReceivedTime
sName = Format(dtDate, "yyyy mm dd", vbUseSystemDayOfWeek, _
vbUseSystem) & Format(dtDate, " hhnn", _
vbUseSystemDayOfWeek, vbUseSystem) & " - " & sName & ".msg"


Debug.Print sPath & "\" & sName
oMail.SaveAs sPath & "\" & sName, olMSG

End If
Next
ETA: oops - can't move everything above the loop, just the folder picker.
 
Status
Not open for further replies.
Top