Consulting

Results 1 to 5 of 5

Thread: Outlook VBA: Moving email and saving attachments to specified folder -2nd'ry email ad

  1. #1
    VBAX Newbie
    Joined
    Feb 2021
    Location
    Stockport, UK
    Posts
    3
    Location

    Outlook VBA: Moving email and saving attachments to specified folder -2nd'ry email ad

    Hi Everyone,

    Briefly...

    Goal:


    To move daily emails sent to a secondary inbox --- i.e., sent from a specific email address---to a sub-folder (Reports) and save the attachment to a location on our network.


    System Specifics:

    OS:
    Windows 7 Pro & Windows 10
    Outlook: version 365
    Email server: Microsoft Exchange


    Progress:

    I have some VBA that I found on via Google which someone else has gotten to work. However, there are some differences in my situation.

    1) I have two email accounts---a primary one (my own email address) and secondary account (an email group called: LogisticsSupport, that has a group email address, the send to!). I would like to VBA to refer to the secondary group email account/address.

    2) The folder I wish to download attachments to is on a network drive: see pic for details (email addresses & folderpath disguised)

    Attachment 27971


    VBA so far:

    Private WithEvents Items As Outlook.Items
     
    'location to save in.  Can be root drive or mapped network drive.
    '-->As it is a constant you can declare it there (and so, use it in the whole module if you want to do other things with it!)
    Private Const attPath As String = "S:etc"
     
     
    Private Sub Application_Startup()
        Dim olApp As Outlook.Application
        Dim objNS As Outlook.NameSpace
        Set olApp = Outlook.Application
        Set objNS = olApp.GetNamespace("MAPI")
        Set Items = objNS.GetDefaultFolder(olFolderInbox).Items
    End Sub
     
    Private Sub Items_ItemAdd(ByVal item As Object)
     
    On Error GoTo ErrorHandler
        'Only act if it's a MailItem
        If TypeName(item) = "MailItem" Then
            Dim Msg As Outlook.MailItem
            '-->Use directly the parameter and keep it under wraps using "With", it'll improve efficiency
            With item
                'Change variables to match need. Comment or delete any part unnecessary.
                If (.SenderEmailAddress = "reports email address (below pic/instagram-post)" _
                   Or .Subject = "LOG Leicester | Weekly Despatches by Courier and Customer" _
                   ) _
                   And .Attachments.Count >= 1 Then
     
     
                    Dim aAtt As Outlook.Attachment
                    '-->Loop through the Attachments' collection
                    For Each aAtt In item.Attachments
                        '-->You can either use aAtt.DisplayName or aAtt.FileName
                        '-->You can test aAtt.Size or aAtt.Type
     
                        'save attachment
                        aAtt.SaveAsFile attPath & aAtt.DisplayName
                    Next aAtt
     
                    'mark as read
                    .UnRead = False
     
                    Dim olDestFldr As Outlook.MAPIFolder
                    Set FldrDest = Session.folders("LogisticsSupport").folders("Inbox").folders("Reports")
                    If .Parent.Name = "Reports" And .Parent.Parent.Name = "Inbox" Then
                        'MailItem is already in destination folder
                    Else
                        Set Msg = .Move(FldrDest)
                        MsgBox Msg.SenderEmailAddress & vbCrLf & Msg.Subject
                        'Msg.delete
                    End If
                End If
            End With 'item
        End If
     
     
    ProgramExit:
      Exit Sub
     
    ErrorHandler:
      MsgBox Err.Number & " - " & Err.Description
      Resume ProgramExit
    End Sub
    I've put this code into: ThisOutlookSession (not a module). As far as I understand it, when Outlook opens, the VBA directs an inbox search for mail sent from the senders email address (see pic) to the secondary email account (see pic). I think I need to refer specifically to the secondary email account somehow in order for it to search the correct inbox (see picture for details).

    Please would you help me understand/modify this VBA to do the job?
    Attached Images Attached Images
    Last edited by dougmarkham; 02-19-2021 at 05:31 AM.
    Kind regards,

    Doug

  2. #2
    VBAX Newbie
    Joined
    Feb 2021
    Location
    Stockport, UK
    Posts
    3
    Location
    I realised this forum makes pics thumbnails.
    Here is a pic with higher resolution.l

    https://www.instagram.com/p/CLeUfLQn..._web_copy_link
    Kind regards,

    Doug

  3. #3
    Frankly I wouldn't do it like that.

    I would use a Rule to identify the incoming messages and move them to the appropriate sub folder, associated with a script to save the attachments in a Windows folder of your choice.
    The script below will save only pdf files. Modify as appropriate to get only the files you want, bearing in mind that any graphics in the message will count as attachments.
    You can use the test message to test the code with a message already received, before committing it to a rule.
    If there is no script option in rules - see https://www.slipstick.com/outlook/ru...-script-rules/
    See also http://www.vbaexpress.com/forum/show...ttachments-VBA

    Sub SaveAttachments(Item As Outlook.MailItem)
    Const strPath As String = "S:\Path\"
    Dim olAtt As Attachment
    Dim strExt As String
    Dim strFilename As String
        If TypeName(Item) = "MailItem" Then
            If Item.Attachments.Count > 0 Then
                For Each olAtt In Item.Attachments
                    strExt = LCase(Mid(olAtt.FileName, InStrRev(olAtt.FileName, Chr(46))))
                    If strExt = ".pdf" Then 'e.g. save only pdf file attachments
                        strFilename = strPath & olAtt.FileName
                        olAtt.SaveAsFile strFilename
                    End If
                Next olAtt
            End If
        End If
    lbl_Exit:
        Exit Sub
    End Sub
    
    Sub TestMacro()
    Dim olMsg As MailItem
        On Error Resume Next
        Select Case Outlook.Application.ActiveWindow.Class
            Case olInspector
                Set olMsg = ActiveInspector.currentItem
            Case olExplorer
                Set olMsg = Application.ActiveExplorer.Selection.Item(1)
        End Select
        SaveAttachments olMsg
    lbl_Exit:
        Exit Sub
    End Sub
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  4. #4
    VBAX Newbie
    Joined
    Feb 2021
    Location
    Stockport, UK
    Posts
    3
    Location
    Hi Gmayor,
    Thank you for your reply, very nice code: the code indeed works with a rule; however, on our exchange server, rules won't run automatically for some reason...

    Probably this from the spiceworks forum is why:
    Outlook rules and journalling on mailboxes that have an alias listed as the "JournalingReportNdrTo" in an Exchange transport rule do not run. This is a new security feature for newer versions of Exchange Server.
    Once I changed the JournalingReportNdrTo to another account this it resolved my issue!
    I was wondering if you knew whether there is there a way to use a vb script file through task scheduler in order to run your macro?
    Last edited by dougmarkham; 02-22-2021 at 09:30 AM.
    Kind regards,

    Doug

  5. #5
    If you can't run rules, then I guess we are back to Events
    Try the following which is closely based on the code I posted earlier.. You can test it by running 'Application_Startup' from the VBA editor then drag a suitable message to the inbox of the account. It should work if the account display name is correct, the sender e-mail address is correct and the path exists. If you change anything run the aforementioned macro again to reset.
    Option Explicit
    Private WithEvents Items As Outlook.Items
    Const strAcc = "LogisticsSupport@thecompany.com" 'account displayname
    Const strPath As String = "S:\Path\" 'folder to save the attachments
    
    
    Private Sub Application_Startup()
    Dim olFolder As Outlook.Folder
    Dim olAccount As Account
        For Each olAccount In Session.Accounts
            If olAccount.DisplayName = strAcc Then
                Set olFolder = olAccount.DeliveryStore.GetDefaultFolder(olFolderInbox)
                Set Items = olFolder.Items
                Exit For
            End If
        Next olAccount
    End Sub
    
    
    Private Sub Items_ItemAdd(ByVal item As Object)
    Dim olAtt As Attachment
    Dim strExt As String
    Dim strFilename As String
        If TypeName(item) = "MailItem" Then
            If item.SenderEmailAddress = "reports@thecompany.com" Then
                If item.Attachments.Count > 0 Then
                    For Each olAtt In item.Attachments
                        strExt = LCase(Mid(olAtt.FileName, InStrRev(olAtt.FileName, Chr(46))))
                        If strExt = ".pdf" Then    'e.g. save only pdf file attachments
                            strFilename = strPath & olAtt.FileName
                            olAtt.SaveAsFile strFilename
                        End If
                    Next olAtt
                End If
            End If
        End If
    lbl_Exit:
        Exit Sub
    End Sub
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •