Code Change to Save multi-selected emails

[nathandavies]

Hi All,
I have this code which has been working really good for a couple of months, but i'm wondering if anyone could help me change it slightly. At the minute i have to select an email one at a time to save the email i was wondering if there is anyone i could select multiple emails and they all save at the same time.

this is my code i have.

Option ExplicitPrivate Const strRoot As String = "\\SERVER\Projects\drawings\"
 
Sub SAVE()
    Dim olMsg As MailItem
     'On Error Resume Next
    Set olMsg = ActiveExplorer.Selection.Item(1)
    SaveItem olMsg
lbl_Exit:
    Exit Sub
End Sub
 
Private Function GetPath(strCustomer As String) As String
    Dim FSO As Object
    Dim Folder As Object
    Dim subFolder As Object
    Dim strPath As String
    Dim bPath As Boolean
Start:
    strPath = InputBox("Enter Project Number.")
    If strPath = "" Then GoTo lbl_Exit
    If Not Len(strPath) = 5 And Not IsNumeric(Right(strPath, 4)) Then
        MsgBox "Enter a Letter and 4 digits!"
GoTo Start:
    End If
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set Folder = FSO.GetFolder(strRoot & Chr(92) & strCustomer) 'error on strRoot?
    For Each subFolder In Folder.SubFolders
         'Debug.Print subFolder & vbTab & strRoot & strPath
        If InStr(1, CStr(subFolder), UCase(strPath)) > 0 Then
            strPath = CStr(subFolder)
            bPath = True
            Exit For
        End If
    Next
    If Not bPath Then strPath = ""
lbl_Exit:
    GetPath = strPath
    Exit Function
End Function
 
Sub SaveItem(olItem As MailItem)
    Dim objItem As Outlook.MailItem
    Dim fname As String
    Dim fPath1 As String, fPath2 As String
    Dim strPath As String, strSavePath As String
    fPath1 = InputBox("Enter the customer folder name in which to save the message." & vbCr & _
    "The path will be created if it doesn't exist.", _
    "Save Message")
    fPath1 = Replace(fPath1, "\", "")
     
    fPath2 = GetPath(fPath1)
    If fPath2 = "" Then
        MsgBox "The project number does not exist!"
         'so end processing
        GoTo lbl_Exit
    End If
     
    strPath = fPath2
       
     'CreateFolders strPath 'superfluous as the following line will create strPath
    CreateFolders strPath & "\Correspondence" & "\Sent"
    CreateFolders strPath & "\Correspondence" & "\Received"
    CreateFolders strPath & "\Documents" & "\Documents Received"
     'vProject = Split(fPath2, Chr(92))
     'strProject = vProject(UBound(vProject) - 1)
     'Debug.Print strProject
   
    If olItem.Sender Like "Nathan Davies" Then 'Looks for messages from you
        fname = Format(olItem.SentOn, "yyyymmdd") & Chr(32) & _
        Format(olItem.SentOn, "HH.MM") & Chr(32) & olItem.SenderName & " - " & olItem.Subject
        strSavePath = strPath & "\Correspondence\Sent\"
    Else
        fname = Format(olItem.ReceivedTime, "yyyymmdd") & Chr(32) & _
        Format(olItem.ReceivedTime, "HH.MM") & Chr(32) & olItem.SenderName & " - " & olItem.Subject
        strSavePath = strPath & "\Correspondence\Received\"
    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(124), "-")
    SaveUnique olItem, strSavePath, fname
    


     If MsgBox("Save Attachments?", vbYesNo, "Save Attachments?") = vbYes Then
           SaveAttachments olItem, strPath & "\Documents\Documents Received\"
        End If
    If MsgBox("Save To Excel?", vbYesNo, "Save Attachments?") = vbYes Then
          CopyToExcel olItem, strPath 'The line goes here
           End If
lbl_Exit:
 
End Sub
 
Private Sub SaveAttachments(olItem As MailItem, strSaveFolder As String)
     'An Outlook macro by Graham Mayor
    Dim olAttach As Attachment
    Dim strFname As String
    Dim strExt As String
    Dim j As Long
    On Error GoTo CleanUp
    If olItem.Attachments.Count > 0 Then
        For j = olItem.Attachments.Count To 1 Step -1
            Set olAttach = olItem.Attachments(j)
            If Not olAttach.FileName Like "image*.*" Then
                strFname = olAttach.FileName
                strExt = Right(strFname, Len(strFname) - InStrRev(strFname, Chr(46)))
                strFname = FileNameUnique(strSaveFolder, strFname, strExt)
                olAttach.SaveAsFile strSaveFolder & strFname
                 'olAttach.Delete        'delete the attachment
            End If
        Next j
        olItem.SAVE
    End If
CleanUp:
    Set olAttach = Nothing
    Set olItem = Nothing
lbl_Exit:
    Exit Sub
End Sub
 
Private Function FileNameUnique(strPath As String, _
    strFileName As String, _
    strExtension As String) As String
     'An Outlook macro by Graham Mayor
    Dim lngF As Long
    Dim lngName As Long
    lngF = 1
    lngName = Len(strFileName) - (Len(strExtension) + 1)
    strFileName = Left(strFileName, lngName)
    Do While FileExists(strPath & strFileName & Chr(46) & strExtension) = True
        strFileName = Left(strFileName, lngName) & "(" & lngF & ")"
        lngF = lngF + 1
    Loop
    FileNameUnique = strFileName & Chr(46) & strExtension
lbl_Exit:
    Exit Function
End Function
 
Public Sub CreateFolders(strPath As String)
     'A Graham Mayor/Greg Maxey AddIn Utility Macro
    Dim oFSO As Object
    Dim lngPathSep As Long
    Dim lngPS As Long
    If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
    lngPathSep = InStr(3, strPath, "\")
    If lngPathSep = 0 Then GoTo lbl_Exit
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    Do
        lngPS = lngPathSep
        lngPathSep = InStr(lngPS + 1, strPath, "\")
        If lngPathSep = 0 Then Exit Do
        If Len(Dir(Left(strPath, lngPathSep), vbDirectory)) = 0 Then Exit Do
    Loop
    Do Until lngPathSep = 0
        If Not oFSO.FolderExists(Left(strPath, lngPathSep)) Then
            oFSO.CreateFolder Left(strPath, lngPathSep)
        End If
        lngPS = lngPathSep
        lngPathSep = InStr(lngPS + 1, strPath, "\")
    Loop
lbl_Exit:
    Set oFSO = Nothing
    Exit Sub
End Sub
 
Private Function SaveUnique(oItem As Object, _
    strPath As String, _
    strFileName As String)
    Dim lngF As Long
    Dim lngName As Long
    lngF = 1
    lngName = Len(strFileName)
    Do While FileExists(strPath & strFileName & ".msg") = True
        strFileName = Left(strFileName, lngName) & "(" & lngF & ")"
        lngF = lngF + 1
    Loop
    oItem.SaveAs strPath & strFileName & ".msg"
lbl_Exit:
    Exit Function
End Function
 
Private Function FileExists(filespec As String) As Boolean
    Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    If FSO.FileExists(filespec) Then
        FileExists = True
    Else
        FileExists = False
    End If
lbl_Exit:
    Exit Function
End Function
 
Private Function FolderExists(fldr As String) As Boolean
    Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    If (FSO.FolderExists(fldr)) Then
        FolderExists = True
    Else
        FolderExists = False
    End If
lbl_Exit:
    Exit Function
End Function
Sub CopyToExcel(olItem As MailItem, strFolder As String)
     
    Dim xlApp As Object
    Dim xlWB As Object
    Dim xlSheet As Object
    Dim rCount As Long
    Dim bXStarted As Boolean
    Dim strPath As String
    Dim objFolder As Outlook.MAPIFolder
    Dim strColA, strColB, strColC, strColD, strColE, strColF As String
     
     ' Get Excel set up
     'the path of the workbook
    Do Until Right(strFolder, 1) = Chr(92)
        strFolder = strFolder & Chr(92)
    Loop
    strPath = strFolder & "correspondence\email register.xlsx"
    On Error Resume Next
    Set xlApp = GetObject(, "Excel.Application")
    If Err <> 0 Then
        Set xlApp = CreateObject("Excel.Application")
        bXStarted = True
    End If
     'etc


   On Error Resume Next
     ' Open the workbook to input the data
     ' Create workbook if doesn't exist
    Set xlWB = xlApp.Workbooks.Open(strPath)
    If Err <> 0 Then
        Set xlWB = xlApp.Workbooks.Add
        xlWB.SaveAs FileName:=strPath
    End If
    On Error GoTo 0
    Set xlSheet = xlWB.Sheets("email")
     
    On Error Resume Next
     ' add the headers if not present
    If xlSheet.Range("A7") = "" Then
        xlSheet.Range("A7") = "Sender Name"
        xlSheet.Range("B7") = "Sent To"
        xlSheet.Range("C7") = "Date"
        xlSheet.Range("D7") = "Subject"
        xlSheet.Range("E7") = "Body"
    End If
     
     'Find the next empty line of the worksheet
    rCount = xlSheet.Range("B" & xlSheet.Rows.Count).End(-4162).Row
     'needed for Exchange 2016. Remove if causing blank lines.
    rCount = rCount + 1
     
     'collect the fields
     
    strColA = olItem.SenderName
    strColB = olItem.To
    strColC = olItem.ReceivedTime
    strColD = olItem.Subject
    strColE = olItem.Body
             
     ' Get the Exchange address
     ' if not using Exchange, this block can be removed
    Dim olEU As Outlook.ExchangeUser
    Dim oEDL As Outlook.ExchangeDistributionList
    Dim recip As Outlook.Recipient
    Set recip = Application.Session.CreateRecipient(strColC)
     
     
    If InStr(1, strColB, "/") > 0 Then
         ' if exchange, get smtp address
        Select Case recip.AddressEntry.AddressEntryUserType
        Case OlAddressEntryUserType.olExchangeUserAddressEntry
            Set olEU = recip.AddressEntry.GetExchangeUser
            If Not (olEU Is Nothing) Then
                strColC = olEU.PrimarySmtpAddress
            End If
        Case OlAddressEntryUserType.olOutlookContactAddressEntry
            Set olEU = recip.AddressEntry.GetExchangeUser
            If Not (olEU Is Nothing) Then
                strColC = olEU.PrimarySmtpAddress
            End If
        Case OlAddressEntryUserType.olExchangeDistributionListAddressEntry
            Set oEDL = recip.AddressEntry.GetExchangeDistributionList
            If Not (oEDL Is Nothing) Then
                strColC = olEU.PrimarySmtpAddress
            End If
        End Select
    End If
     ' End Exchange section
     
     
     'write them in the excel sheet
    xlSheet.Range("A" & rCount) = strColA
    xlSheet.Range("B" & rCount) = strColB
    xlSheet.Range("c" & rCount) = strColC
    xlSheet.Range("d" & rCount) = strColD
    xlSheet.Range("e" & rCount) = strColE
     
     'Next row
    rCount = rCount + 1
    xlWB.SAVE
     
     'wrap lines
    xlSheet.Rows.WrapText = True
     
     
    xlWB.SAVE
    xlWB.Close 1
     
    If bXStarted Then
         'xlApp.Quit 'With looped messages it will be faster if Excel is not closed
    End If
    Set xlApp = Nothing
    Set xlWB = Nothing
    Set xlSheet = Nothing
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