Adjusting code so it can handle multiple selections

[cjmitton]

I have the code which I've patched together to auto save emails

I used code from some other postings and works fine for individual selections but need to tweak it so it can handle mulitple selections (i.e. when your viewing the inbox using the ctrl or shift key to select a group of emails) to save them to a specific directory selected. I need this flexability for it to work for my users!

I've tried to do a loop but have failed as my VBA coding itsnt up to it! Any help is greatfully received.


Sub DFA_Save()
On Error GoTo Err_Msg
Dim objItem As Outlook.MailItem
Dim strPrompt As String, strName As String
Dim sreplace As String, mychar As Variant, strdate As String

Set objItem = Outlook.ActiveExplorer.Selection.Item(1)
If objItem.Class = olMail Then
If objItem.Subject <> vbNullString Then
strName = objItem.Subject
Else
strName = "No Subject"
End If

Dim strFolder As String
Dim strStartDir As Variant
strStartDir = "H:\"
strFolder = PickFolder(strStartDir)
If strFolder = "" Then Exit Sub
strTo = objItem.ReceivedByName
strFrom = objItem.SenderName
strdate = objItem.ReceivedTime
sreplace = "-"

For Each mychar In Array("/", "\", ":", "?", Chr(34), "<", ">", "¦")
strName = Replace(strName, mychar, sreplace)
strdate = Replace(strdate, mychar, sreplace)
strFrom = Replace(strFrom, mychar, sreplace)
strTo = Replace(strTo, mychar, sreplace)
Next mychar
strPrompt = "Are you sure you want to save the item?"
If MsgBox(strPrompt, vbYesNo + vbQuestion) = vbYes Then
objItem.SaveAs strFolder & "\" & Format(Now, "yy-mm-dd") & " " & strFrom & " - " _
& strName & " Received By " & strTo & " on " & strdate & ".msg", olMSG
Else
MsgBox "You chose not to save."
End If

Else
Exit Sub
End If

Exit Sub
Err_Msg:
MsgBox "Item Not Selected or is not an Email", vbOKOnly, "Error"
End Sub



I know I need to move the part of selecting the folder to the beginning before I start the loop for each email selected but failed from there! I thought it best to put the code I started with / knows works!

[skatonni]

You will surely want to have a single message box to confirm the bulk save.


Sub DFA_Save_Multiple()
On Error GoTo Err_Msg

Dim objItem As Object ' <------
Dim strPrompt As String, strName As String
Dim sreplace As String, mychar As Variant, strdate As String

Dim MySelection As Selection

Dim iCount As Long
Dim iItem As Long

Dim strTo As String
Dim strFrom As String

Dim strFolder As String
Dim strStartDir As Variant
strStartDir = "H:\"

strFolder = "H:"
' strFolder = PickFolder(strStartDir)
' You probably want BrowseForFolder http://www.vbaexpress.com/kb/getarticle.php?kb_id=284

If strFolder = "" Then Exit Sub

Set MySelection = Outlook.ActiveExplorer.Selection

For iItem = 1 To MySelection.Count

Set objItem = MySelection.item(iItem)

If objItem.Class = olMail Then

If objItem.Subject <> vbNullString Then
strName = objItem.Subject
Else
strName = "No Subject"
End If

strTo = objItem.ReceivedByName
strFrom = objItem.SenderName
strdate = objItem.ReceivedTime
sreplace = "-"

For Each mychar In Array("/", "\", ":", "?", Chr(34), "<", ">", "¦")
strName = Replace(strName, mychar, sreplace)
strdate = Replace(strdate, mychar, sreplace)
strFrom = Replace(strFrom, mychar, sreplace)
strTo = Replace(strTo, mychar, sreplace)
Next mychar

strPrompt = "Are you sure you want to save the item?"
If MsgBox(strPrompt, vbYesNo + vbQuestion) = vbYes Then

Debug.Print "Saving item " & iItem & ": " & strName
Debug.Print " as: " & strFolder & "\" & Format(Now, "yy-mm-dd") & " " & strFrom & " - " _
& strName & " Received By " & strTo & " on " & strdate & ".msg" & vbCr

objItem.SaveAs strFolder & "\" & Format(Now, "yy-mm-dd") & " " & strFrom & " - " _
& strName & " Received By " & strTo & " on " & strdate & ".msg", olMSG
Else
MsgBox "You chose not to save."
End If

Else
MsgBox "Item " & iItem & " is not an Email", vbOKOnly, "Error"
' Exit Sub
End If

Next iItem

GoTo exitRoutine

Err_Msg:
MsgBox "Item Not Selected or is not an Email", vbOKOnly, "Error"
exitRoutine:
Set MySelection = Nothing
Set objItem = Nothing
End Sub

[cjmitton]

Thanks Skatonni,

I'm not in the office now until Tuesday but will check it out then. Makes perfect sense what you've done. I'll also look in to the Browse for Folder function you've linked on there to.

Thanks very much your help no doubt I'll have a question or two on Tuesday :)

[cjmitton]

Skatonni,

I have been able to find time yesterday to finally have a play with your code and with my users tweak it to there current requirements.

After looking around for the selecting folder solution (they said yesterday they wanted to link to not just a mapped drive but also see there favourites too) I found the one below included in the code that workes a treat!

I've also tweaked it so the if one file is selected it does not ask any more questions but more than one states how many have been selected then then saves them all (which is what my users wanted).

Thanks for your help! The code is below so any comments / adjustment are most welcome.


Function GetFolder(strPath As String) As String
Dim exObject As Excel.Application
Set exObject = New Excel.Application
Dim fldr As FileDialog
Dim sItem As String
Set fldr = exObject.Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a Folder"
.AllowMultiSelect = False
.InitialFileName = strPath
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
GetFolder = sItem
Set fldr = Nothing
End Function
Sub DFA_Save_Multiple()
On Error GoTo Err_Msg

Dim objItem As Object
Dim strPrompt As String, strName As String, strPromptYN As String
Dim sreplace As String, mychar As Variant, strdate As String

Dim MySelection As Selection

Dim iCount As String
Dim iItem As Long

Dim strTo As String
Dim strFrom As String

Dim strFolder As String
strFolder = GetFolder("G:\")
If strFolder = "" Then Exit Sub

Set MySelection = Outlook.ActiveExplorer.Selection

iCount = MySelection.Count
If iCount > 1 Then GoTo MultiSave Else GoTo Saveit
MultiSave:
strPromptYN = "You've selected " & iCount & " Items" & vbCrLf & "Do you wish to continue"
If MsgBox(strPromptYN, vbYesNo) = vbYes Then
Saveit:
For iItem = 1 To MySelection.Count

Set objItem = MySelection.Item(iItem)

If objItem.Class = olMail Then

If objItem.Subject <> vbNullString Then
strName = objItem.Subject
Else
strName = "No Subject"
End If
strTo = objItem.ReceivedByName
strFrom = objItem.SenderName
strdate = objItem.ReceivedTime
sreplace = "-"

For Each mychar In Array("/", "\", ":", "?", Chr(34), "<", ">", "¦")
strName = Replace(strName, mychar, sreplace)
strdate = Replace(strdate, mychar, sreplace)
strFrom = Replace(strFrom, mychar, sreplace)
strTo = Replace(strTo, mychar, sreplace)
Next mychar
' *** if multi acceptance of each save required ***
' strPrompt = "Are you sure you want to save the item?"
' If MsgBox(strPrompt, vbYesNo + vbQuestion) = vbYes Then

Debug.Print "Saving item " & iItem & ": " & strName
Debug.Print " as: " & strFolder & "\" & Format(Now, "yy-mm-dd") & " " & strFrom & " - " _
& strName & " Received By " & strTo & " on " & strdate & ".msg" & vbCr

objItem.SaveAs strFolder & "\" & Format(Now, "yy-mm-dd") & " " & strFrom & " - " _
& strName & " Received By " & strTo & " on " & strdate & ".msg", olMSG
' Else
' MsgBox "You chose not to save."
' End If

Else
MsgBox "Item " & iItem & " is not an Email", vbOKOnly, "Error"
End If

Next iItem

GoTo exitRoutine

Else
MsgBox "No Items Have been Saved", vbInformation
GoTo exitRoutine
End If


Err_Msg:
MsgBox "Item Not Selected or is not an Email", vbOKOnly, "Error"
exitRoutine:
Set MySelection = Nothing
Set objItem = Nothing
End Sub