Code Change to Save multi-selected emails

**nathandavies** · 07-31-2017, 08:34 AM

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

**skatonni** · 07-31-2017, 01:52 PM

To loop through each item in the selection:

Sub SAVE_multiSelection()

    Dim olObj As Object
    Dim olMsg As mailitem

    Dim selCount As Long
    Dim j As Long
    
    selCount = ActiveExplorer.Selection.count
    
    For j = selCount To 1 Step -1
    
        Set olObj = ActiveExplorer.Selection.Item(j)
        
        If olObj.Class = olMail Then
            Set olMsg = olObj
            Debug.Print olMsg.Subject
            'SaveItem olMsg
        End If
        
    Next j
    
End Sub

**nathandavies** · 07-31-2017, 02:57 PM

Do I put this code in the place of the sub_SAVE or as well as.

thanks for your quick reply!!

**gmayor** · 07-31-2017, 08:10 PM

As well as. It's an alternative means of driving the main macro. That main macro (SaveItem) can also be run from a rule to process the messages as they arrive, so there is then no need to subsequently batch process them. However in both cases you would probably want to get rid of the confirmation prompts.

**nathandavies** · 08-01-2017, 12:49 AM

I have managed to put the modification into my code and it works for when i have multiple emails selected only issue i have is, i Have to keep inputting information to the input boxes to save the emails in the location. I was hoping to only have to put the information in once and it would save the multiple emails in the same location. is this possible?

full code for viewing.

Option ExplicitPrivate Const strRoot As String = "\\NEWBENSON\Projects\drawings\"
Sub Save()
    Dim olObj As Object
    Dim olMsg As MailItem
    Dim selCount As Long
    Dim j As Long
     
    selCount = ActiveExplorer.Selection.Count
     
    For j = selCount To 1 Step -1
    Set olObj = ActiveExplorer.Selection.Item(j)
    If olObj.Class = olMail Then
    Set olMsg = olObj
    Debug.Print olMsg.Subject
    SaveItem olMsg
    End If
         
  Next j
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)
     'An Outlook macro by Graham Mayor - www.gmayor.com
    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
     'An Office macro by Graham Mayor - www.gmayor.com
    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
     'An Office macro by Graham Mayor - www.gmayor.com
    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

**gmayor** · 08-01-2017, 03:47 AM

I did warn about that in my last post. The problem is that you now want to process multiple messages. Provided all those messages relate to the same customer, and have the same project number, then you can move the prompts to the calling macro and feed the results back to the individual macros that require them. If they are for different customers and/or different projects then how are you going to determine which customer and which project to file under?

**nathandavies** · 08-01-2017, 04:04 AM

We will only select emails from the same customer with the same project number for saving the email.

Which prompt do i need to move? I have all these macros running from one macro button at the minute.

**nathandavies** · 08-08-2017, 06:36 AM

Would there be a way to script the inputted information in multiple times to the input boxes for a set of emails?

**nathandavies** · 08-16-2017, 03:02 AM

Is there anyone who would be able to help with the above? I have tried different codes and nothing works, i have had to revert back to my old code at the minute.

**gmayor** · 08-18-2017, 04:37 AM

I have not had time to return to this as I have been doing real work for a private client, however, I think the following should work.

Option Explicit

Private Const strRoot As String = "\\NEWBENSON\Projects\drawings\"

Public Sub SaveMessages()
'Graham Mayor - http://www.gmayor.com - Last updated - 18 Aug 2017
Dim olObj As Object
Dim olMsg As MailItem
Dim selCount As Long
Dim j As Long
Dim fPath1 As String, fPath2 As String
Dim strPath As String, strSavePath As String

    selCount = ActiveExplorer.Selection.Count
    If selCount = 0 Then GoTo lbl_Exit

    fPath1 = InputBox("Enter the customer folder name in which to save the messages." & 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 & "\Correspondence" & "\Sent"
    CreateFolders strPath & "\Correspondence" & "\Received"
    CreateFolders strPath & "\Documents" & "\Documents Received"

    For j = selCount To 1 Step -1
        Set olObj = ActiveExplorer.Selection.Item(j)
        If olObj.Class = olMail Then
            Set olMsg = olObj
            'if you want the attachments saved bAttach:=True
            'If you want to copy to Excel then bExcel:=True
            SaveItem olItem:=olMsg, strPath:=strPath, bAttach:=False, bExcel:=False
        End If
    Next j
lbl_Exit:
    Exit Sub
End Sub

Private Function GetPath(strCustomer As String) As String
'Graham Mayor - http://www.gmayor.com - Last updated - 18 Aug 2017
Dim FSO As Object
Dim Folder As Object
Dim subFolder As Object
Dim bPath As Boolean
Dim strPath As String

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

Private Sub SaveItem(olItem As MailItem, strPath As String, bAttach As Boolean, bExcel As Boolean)
'Graham Mayor - http://www.gmayor.com - Last updated - 18 Aug 2017
Dim fname As String
Dim strSavePath As String

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 bAttach = True Then
        SaveAttachments olItem, strPath & "\Documents\Documents Received\"
    End If
    If bExcel = True Then
        CopyToExcel olItem, strPath
    End If
lbl_Exit:
    Exit Sub
End Sub

Private Sub SaveAttachments(olItem As MailItem, strSaveFolder As String)
'Graham Mayor - http://www.gmayor.com - Last updated - 18 Aug 2017
Dim olAttach As Attachment
Dim strFname As String
Dim strExt As String
Dim j As Long
    On Error GoTo lbl_Exit
    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
lbl_Exit:
    Set olAttach = Nothing
    Set olItem = Nothing
    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

Private 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)
'An Outlook macro by Graham Mayor - www.gmayor.com
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
    'Debug.Print strPath & strFileName & ".msg"
    oItem.SaveAs strPath & strFileName & ".msg"
lbl_Exit:
    Exit Function
End Function

Private Function FileExists(filespec As String) As Boolean
'An Office macro by Graham Mayor - www.gmayor.com
Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    If FSO.FileExists(filespec) Then
        FileExists = True
    Else
        FileExists = False
    End If
lbl_Exit:
    Set FSO = Nothing
    Exit Function
End Function

Private Function FolderExists(fldr As String) As Boolean
'An Office macro by Graham Mayor - www.gmayor.com
Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    If (FSO.FolderExists(fldr)) Then
        FolderExists = True
    Else
        FolderExists = False
    End If
lbl_Exit:
    Set FSO = Nothing
    Exit Function
End Function

Private Sub CopyToExcel(olItem As MailItem, strFolder As String)
'Graham Mayor - http://www.gmayor.com - Last updated - 18 Aug 2017
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")
    End If

    ' 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

lbl_Exit:
    Set xlApp = Nothing
    Set xlWB = Nothing
    Set xlSheet = Nothing
    Exit Sub
End Sub

**nathandavies** · 08-18-2017, 06:47 AM

Graham,

with a few tweaks this has worked perfectly thanks

**nathandavies** · 08-22-2017, 05:22 AM

Graham, I have made another modification to the code, so that if I send an email it asks if i want to save the attachment or not in a different folder but i keep getting an error "Function Call on left-hand side of assignment must return variant or object"

Any ideas how to solve this issue?

      If olItem.Sender Like "Nathan Davies" Then 'INSERT NAME HERE        
        MsgBox("Save Attachments?", vbYesNo, "Save Attachments?") = vbYes
        SaveAttachments olItem, strPath & "\Documents\Documents Sent\"
    Else
        SaveAttachments olItem, strPath & "\Documents\Documents Received\"
    
    'If bExcel = True Then
    'CopyToExcel olItem, strPath
    
       End If
lbl_Exit:
    Exit Sub
End Sub

Thread: Code Change to Save multi-selected emails

Thread Tools

Display

Code Change to Save multi-selected emails

Tags for this Thread

Posting Permissions