Использование VBA для автоматизации - сохранение нескольких вложений на основе нескольких критериев в определенных папках - PullRequest
Новая
       19

Использование VBA для автоматизации - сохранение нескольких вложений на основе нескольких критериев в определенных папках

1 голос
/ 10 ноября 2019

Ситуация : я отправляю ежедневные отчеты нескольким заинтересованным сторонам (~ 10) на основе некоторых критериев. Я новичок в VBA, поэтому попытался с некоторой помощью здесь скомпилировать приведенный ниже код, поэтому, пожалуйста, потерпите меня:

  • Критерии 1: загрузка вложений на основе отправителей и 1 или2 ключевых слова от отправителя электронной почты и темы
  • Критерии 2: Исключить выходные дни, так как отчеты только отправляются и получают ответы от соответствующих заинтересованных сторон в рабочие дни. На этой заметке отчеты за понедельник необходимо будет загрузить из приложения в пятницу
  • Критерии 3: одна компания имеет 4 региона, остальные просто централизованы. Сказав это, после загрузки вложений из компании с 4 регионами мне нужно, чтобы вложение было сохранено в папке под названием компании. Принимая во внимание, что с остальными компаниями они все сохранены в соответствующем названии папки компании. Файлы будут более информативными с указанием года, месяца и дня, в отличие от родительской папки, ограниченной названием компании и только год и месяц .

Все вышеперечисленное было предпринято иприлагается здесь. Мне также нужно создать автоматизацию, в которой в каждой папке будут храниться файлы максимум 2 месяца, после чего будет создана другая папка с новыми вложениями тех месяцев, которые будут заполняться.

Я ценю, что мой код неуклюжий, и мне нужна более быстрая версия, пожалуйста. Любая помощь будет принята с благодарностью: 

Option Explicit

Sub SaveOutlookAttachments()

Dim objOutlook As New Outlook.Application
Dim objNamespace As Outlook.Namespace
Dim objFolder As Outlook.folder
Dim objItem As Object
Dim objMailItem As Outlook.MailItem
Dim objAttachment As Outlook.Attachment

'For Folders creation

Dim fso As Scripting.FileSystemObject
Dim dir As Scripting.Folders
Dim dirFolderName As String


'For Date settings
Dim iBackdate As Integer

' Hardcoding Partners - 
Dim COMP_A_North As String
Dim COMP_A_South As String
Dim COMP_A_East As String
Dim COMP_A_West As String
Dim COMP_B As String
Dim COMP_C As String
Dim COMP_D As String
Dim COMP_E As String
Dim COMP_F As String


Set objNamespace = objOutlook.GetNamespace("MAPI")
Set objFolder = objNamespace.Folders(1).Folders("Inbox")


Set fso = New Scripting.FileSystemObject


'Setting Partner Filters

COMP_A_North = "@SQL=""urn:schemas:httpmail:fromname"" LIKE '%@compa%'" & "AND 
""urn:schemas:httpmail:subject"" LIKE '%Scotland%'"
COMP_A_South = "@SQL=""urn:schemas:httpmail:fromname"" LIKE '%@compa%'" & "AND 
""urn:schemas:httpmail:subject"" LIKE '%North%'"
COMP_A_East = "@SQL=""urn:schemas:httpmail:fromname"" LIKE '%@compa%'" & "AND 
""urn:schemas:httpmail:subject"" LIKE '%Midlands%'"
COMP_A_West = "@SQL=""urn:schemas:httpmail:fromname"" LIKE '%@compa%'" & "AND 
""urn:schemas:httpmail:subject"" LIKE '%London%'"
COMP_B = "@SQL=""urn:schemas:httpmail:fromname"" LIKE '%@compb%'" & "AND 
""urn:schemas:httpmail:subject"" LIKE '%Missing%'"
COMP_C = "@SQL=""urn:schemas:httpmail:fromname"" LIKE '%@compc%'" & "AND 
""urn:schemas:httpmail:subject"" LIKE '%Missing%'"
COMP_D = "@SQL=""urn:schemas:httpmail:fromname"" LIKE '%@compd%'" & "AND 
""urn:schemas:httpmail:subject"" LIKE '%Missing%'"
COMP_E = "@SQL=""urn:schemas:httpmail:fromname"" LIKE '%compe%'" & "AND 
""urn:schemas:httpmail:subject"" LIKE '%Missing%'"
COMP_F = "@SQL=""urn:schemas:httpmail:fromname"" LIKE '%@compf%'" & "AND 
""urn:schemas:httpmail:subject"" LIKE '%Missing%'"


    For Each objItem In objFolder.Items.Restrict(COMP_A_North)

    'Check Item Class
    If objItem.Class = Outlook.olMail Then

      'Set as Mail Item
       Set objMailItem = objItem

       With objMailItem
          Select Case Weekday(Now)
              Case 7 ' Saturday: add extra day
                  iBackdate = 3
              Case 1, 2, 3 ' Sunday through Tuesday: add extra 2 days
                iBackdate = 4
              Case Else ' Other days
                iBackdate = 2
             End Select

        ' Check date
        If .ReceivedTime > DateAdd("d", -iBackdate, Now) Then

                ' Save Attachments

            If objAttachment.Count > 0 Then

            dirFolderName = "C:\Users\rootname\OneDrive\Desktop\VBATesting" & "compa  Report UpTo" & 
            Format(objAttachment.receivetime, "yyyy-mm")

              If fso.FolderExists(dirFolderName) Then
                  Set dir = fso.GetFolder(dirFolderName)
              Else
                  Set dir = fso.CreateFolder(dirFolderName)
              End If



                For Each objAttachment In .Attachments



                    Debug.Print objMailItem.Sender, objMailItem.ReceivedTime, objMailItem.Subject


                        objAttachment.SaveAsFile "C:\Users\rootname\OneDrive\Desktop\VBATesting" & 
    objAttachment.FileName = "compa North and Iceland Region Report" & Format(.ReceivedTime, "yyyy- 
     mm- dd")   'Put in a valid folder location to store attachements


                Next

            End If

        End If

    End With

End If

Next




    For Each objItem In objFolder.Items.Restrict(COMP_A_South)

    'Check Item Class
    If objItem.Class = Outlook.olMail Then

        'Set as Mail Item
         Set objMailItem = objItem

        With objMailItem
            Select Case Weekday(Now)
                Case 7 ' Saturday: add extra day
                    iBackdate = 3
                Case 1, 2, 3 ' Sunday through Tuesday: add extra 2 days
                    iBackdate = 4
                Case Else ' Other days
                    iBackdate = 2
            End Select

            ' Check date
            If .ReceivedTime > DateAdd("d", -iBackdate, Now) Then

                ' Save Attachments
                If objAttachment.Count > 0 Then

                dirFolderName = "C:\Users\rootname\OneDrive\Desktop\VBATesting" & "compa  Report 
                UpTo" & Format(objAttachment.receivetime, "yyyy-mm")

                If fso.FolderExists(dirFolderName) Then
                    Set dir = fso.GetFolder(dirFolderName)
                Else
                    Set dir = fso.CreateFolder(dirFolderName)
                End If


                        For Each objAttachment In .Attachments
                        Debug.Print objMailItem.Sender, objMailItem.ReceivedTime, 
                        objMailItem.Subject


                        objAttachment.SaveAsFile "C:\Users\rootname\OneDrive\Desktop\VBATesting" & 
                        objAttachment.FileName = "compa South Region  Report" & 
                        Format(.ReceivedTime, "yyyy-mm-dd")   'Put in a valid folder location to 
                        store attachements

                    Next

            End If

        End If

    End With

End If

Next


For Each objItem In objFolder.Items.Restrict(COMP_A_East)

    'Check Item Class
    If objItem.Class = Outlook.olMail Then

        'Set as Mail Item
        Set objMailItem = objItem

        With objMailItem
            Select Case Weekday(Now)
                Case 7 ' Saturday: add extra day
                    iBackdate = 3
                Case 1, 2, 3 ' Sunday through Tuesday: add extra 2 days
                    iBackdate = 4
                Case Else ' Other days
                    iBackdate = 2
            End Select

            ' Check date
            If .ReceivedTime > DateAdd("d", -iBackdate, Now) Then

                ' Save Attachments
                If objAttachment.Count > 0 Then

                dirFolderName = "C:\Users\rootname\OneDrive\Desktop\VBATesting" & "compa  Report 
            UpTo" & Format(objAttachment.receivetime, "yyyy-mm")

                If fso.FolderExists(dirFolderName) Then
                    Set dir = fso.GetFolder(dirFolderName)
                Else
                    Set dir = fso.CreateFolder(dirFolderName)
                End If


                    For Each objAttachment In .Attachments
                    Debug.Print objMailItem.Sender, objMailItem.ReceivedTime, objMailItem.Subject


                        objAttachment.SaveAsFile "C:\Users\rootname\OneDrive\Desktop\VBATesting" & 
objAttachment.FileName = "compa East Region  Report" & Format(.ReceivedTime, "yyyy-mm-dd")   'Put in 
a valid folder location to store attachements

                    Next
            End If

        End If

    End With

End If

Next




For Each objItem In objFolder.Items.Restrict(COMP_A_West)

    'Check Item Class
    If objItem.Class = Outlook.olMail Then

        'Set as Mail Item
        Set objMailItem = objItem

        With objMailItem
            Select Case Weekday(Now)
                Case 7 ' Saturday: add extra day
                    iBackdate = 3
                Case 1, 2, 3 ' Sunday through Tuesday: add extra 2 days
                    iBackdate = 4
                Case Else ' Other days
                    iBackdate = 2
            End Select

            ' Check date
            If .ReceivedTime > DateAdd("d", -iBackdate, Now) Then

                ' Save Attachments
                If objAttachment.Count > 0 Then

                dirFolderName = "C:\Users\rootname\OneDrive\Desktop\VBATesting" & "compa  Report 
UpTo" & Format(objAttachment.receivetime, "yyyy-mm")

            If fso.FolderExists(dirFolderName) Then
                Set dir = fso.GetFolder(dirFolderName)
            Else
                Set dir = fso.CreateFolder(dirFolderName)
            End If

                    For Each objAttachment In .Attachments
                    Debug.Print objMailItem.Sender, objMailItem.ReceivedTime, objMailItem.Subject


                        objAttachment.SaveAsFile "C:\Users\rootname\OneDrive\Desktop\VBATesting" & 
  objAttachment.FileName = "compa West and Central Region  Report" & Format(.ReceivedTime, "yyyy-mm- 
  dd")   'Put in a valid folder location to store attachements

                    Next

            End If

        End If

    End With

End If

Next




For Each objItem In objFolder.Items.Restrict(COMP_B)

    'Check Item Class
    If objItem.Class = Outlook.olMail Then

        'Set as Mail Item
        Set objMailItem = objItem

        With objMailItem
            Select Case Weekday(Now)
                Case 7 ' Saturday: add extra day
                    iBackdate = 3
                Case 1, 2, 3 ' Sunday through Tuesday: add extra 2 days
                    iBackdate = 4
                Case Else ' Other days
                    iBackdate = 2
            End Select

            ' Check date
            If .ReceivedTime > DateAdd("d", -iBackdate, Now) Then

                        ' Save Attachments
                If objAttachment.Count > 0 Then

                dirFolderName = "C:\Users\rootname\OneDrive\Desktop\VBATesting" & "CompB Report 
UpTo" & Format(objAttachment.receivetime, "yyyy-mm")

                If fso.FolderExists(dirFolderName) Then
                    Set dir = fso.GetFolder(dirFolderName)
                Else
                    Set dir = fso.CreateFolder(dirFolderName)
                End If


                    For Each objAttachment In .Attachments
                    Debug.Print objMailItem.Sender, objMailItem.ReceivedTime, objMailItem.Subject


                        objAttachment.SaveAsFile "C:\Users\rootname\OneDrive\Desktop\VBATesting" & 
objAttachment.FileName = "compb Report" & Format(.ReceivedTime, "yyyy-mm-dd")   'Put in a valid 
folder location to store attachements

                    Next
            End If
        End If

    End With

End If

Next




For Each objItem In objFolder.Items.Restrict(COMP_C)

    'Check Item Class
    If objItem.Class = Outlook.olMail Then

        'Set as Mail Item
        Set objMailItem = objItem

    With objMailItem
        Select Case Weekday(Now)
            Case 7 ' Saturday: add extra day
                iBackdate = 3
            Case 1, 2, 3 ' Sunday through Tuesday: add extra 2 days
                iBackdate = 4
            Case Else ' Other days
                iBackdate = 2
        End Select

        ' Check date
        If .ReceivedTime > DateAdd("d", -iBackdate, Now) Then

            ' Save Attachments
            If objAttachment.Count > 0 Then

            dirFolderName = "C:\Users\rootname\OneDrive\Desktop\VBATesting" & "CompC  Report UpTo" & 
 Format(objAttachment.receivetime, "yyyy-mm")

            If fso.FolderExists(dirFolderName) Then
                Set dir = fso.GetFolder(dirFolderName)
            Else
                Set dir = fso.CreateFolder(dirFolderName)
            End If

                    For Each objAttachment In .Attachments
                    Debug.Print objMailItem.Sender, objMailItem.ReceivedTime, objMailItem.Subject


                        objAttachment.SaveAsFile "C:\Users\rootname\OneDrive\Desktop\VBATesting" & 
objAttachment.FileName = "CompC Report" & Format(.ReceivedTime, "yyyy-mm-dd")   'Put in a valid 
folder location to store attachements

                    Next
            End If
        End If

    End With

End If

Next


For Each objItem In objFolder.Items.Restrict(COMP_D)

'Check Item Class
If objItem.Class = Outlook.olMail Then

    'Set as Mail Item
    Set objMailItem = objItem

    With objMailItem
        Select Case Weekday(Now)
            Case 7 ' Saturday: add extra day
                iBackdate = 3
            Case 1, 2, 3 ' Sunday through Tuesday: add extra 2 days
                iBackdate = 4
            Case Else ' Other days
                iBackdate = 2
        End Select

        ' Check date
        If .ReceivedTime > DateAdd("d", -iBackdate, Now) Then

            ' Save Attachments
            If objAttachment.Count > 0 Then

            dirFolderName = "C:\Users\rootname\OneDrive\Desktop\VBATesting" & "CompD Report UpTo" & 
 Format(objAttachment.receivetime, "yyyy-mm")

            If fso.FolderExists(dirFolderName) Then
                Set dir = fso.GetFolder(dirFolderName)
            Else
                Set dir = fso.CreateFolder(dirFolderName)
            End If

                    For Each objAttachment In .Attachments
                    Debug.Print objMailItem.Sender, objMailItem.ReceivedTime, objMailItem.Subject


                        objAttachment.SaveAsFile "C:\Users\rootname\OneDrive\Desktop\VBATesting" & 
 objAttachment.FileName = "compd Report" & Format(.ReceivedTime, "yyyy-mm-dd")   'Put in a valid 
 folder location to store attachements

                    Next
            End If

        End If

    End With

End If

Next




For Each objItem In objFolder.Items.Restrict(COMP_E)

'Check Item Class
If objItem.Class = Outlook.olMail Then

    'Set as Mail Item
    Set objMailItem = objItem

    With objMailItem
        Select Case Weekday(Now)
            Case 7 ' Saturday: add extra day
                iBackdate = 3
            Case 1, 2, 3 ' Sunday through Tuesday: add extra 2 days
                iBackdate = 4
            Case Else ' Other days
                iBackdate = 2
        End Select

        ' Check date
        If .ReceivedTime > DateAdd("d", -iBackdate, Now) Then

            ' Save Attachments
            If objAttachment.Count > 0 Then

            dirFolderName = "C:\Users\rootname\OneDrive\Desktop\VBATesting" & "CompE  Report UpTo" & 
Format(objAttachment.receivetime, "yyyy-mm")

            If fso.FolderExists(dirFolderName) Then
                Set dir = fso.GetFolder(dirFolderName)
            Else
                Set dir = fso.CreateFolder(dirFolderName)
            End If

                    For Each objAttachment In .Attachments
                    Debug.Print objMailItem.Sender, objMailItem.ReceivedTime, objMailItem.Subject


                        objAttachment.SaveAsFile "C:\Users\rootname\OneDrive\Desktop\VBATesting" & 
 objAttachment.FileName = "compe  Report" & Format(.ReceivedTime, "yyyy-mm-dd")   'Put in a valid 
 folder location to store attachements

                    Next
            End If

        End If

    End With

End If

Next


 For Each objItem In objFolder.Items.Restrict(COMP_F)

'Check Item Class
If objItem.Class = Outlook.olMail Then

    'Set as Mail Item
    Set objMailItem = objItem

    With objMailItem
        Select Case Weekday(Now)
            Case 7 ' Saturday: add extra day
                iBackdate = 3
            Case 1, 2, 3 ' Sunday through Tuesday: add extra 2 days
                iBackdate = 4
            Case Else ' Other days
                iBackdate = 2
        End Select

        ' Check date
        If .ReceivedTime > DateAdd("d", -iBackdate, Now) Then

            ' Save Attachments
            If objAttachment.Count > 0 Then

            dirFolderName = "C:\Users\rootname\OneDrive\Desktop\VBATesting" & "CompF  Report UpTo" & 
 Format(objAttachment.receivetime, "yyyy-mm")

            If fso.FolderExists(dirFolderName) Then
                Set dir = fso.GetFolder(dirFolderName)
            Else
                Set dir = fso.CreateFolder(dirFolderName)
            End If

                    For Each objAttachment In .Attachments
                    Debug.Print objMailItem.Sender, objMailItem.ReceivedTime, objMailItem.Subject

                        objAttachment.SaveAsFile "C:\Users\rootname\OneDrive\Desktop\VBATesting" & 
objAttachment.FileName = "compf Report" & Format(.ReceivedTime, "yyyy-mm-dd")   'Put in a valid 
 folder location to store attachements

                    Next
            End If

        End If

    End With

End If

Next


End Sub

1 Ответ

2 голосов
/ 11 ноября 2019

Вот как бы я переделал это. Скомпилировано, но не протестировано, поэтому вам может потребоваться отладка, если она не работает. 

Sub SaveOutlookAttachments()

    Dim objOutlook As New Outlook.Application
    Dim objNamespace As Outlook.Namespace
    Dim objFolder As Outlook.Folder

    Set objNamespace = objOutlook.GetNamespace("MAPI")
    Set objFolder = objNamespace.Folders(1).Folders("Inbox")

    ProcessMails objFolder, "compa", "Scotland", "compa  Report UpTo", "compa Scotland Region Report"
    ProcessMails objFolder, "compa", "North", "compa  Report UpTo", "compa North Region Report"
    ProcessMails objFolder, "compa", "Midlands", "compa  Report UpTo", "compa Midlands Region Report"
    ProcessMails objFolder, "compa", "London", "compa  Report UpTo", "compa London Region Report"


End Sub

Sub ProcessMails(srcFolder As Outlook.Folder, compName As String, subj As String, _
                 saveFolder As String, saveFileName As String)

    Const ROOT_FOLDER As String = "C:\Users\rootname\OneDrive\Desktop\VBATesting\"

    Dim objItem As Object, objMailItem As Outlook.MailItem, dirFolderName As String
    Dim objAttachment As Outlook.Attachment

    For Each objItem In srcFolder.Items.Restrict(PFilter(compName, subj))
        If objItem.Class = Outlook.olMail Then 'Check Item Class

            Set objMailItem = objItem 'Set as Mail Item

            If ProcessThisMail(objMailItem) Then
                With objMailItem

                    dirFolderName = ROOT_FOLDER & saveFolder & _
                                    Format(objMailItem.ReceivedTime, "yyyy-mm") & "\"

                    EnsureSaveFolder dirFolderName

                    Debug.Print "Message:", objMailItem.Sender, objMailItem.ReceivedTime, objMailItem.Subject

                    For Each objAttachment In .Attachments
                        Debug.Print , "Attachment:", objAttachment.Filename

                        objAttachment.SaveAsFile dirFolderName & _
                              saveFileName & Format(objMailItem.ReceivedTime, "yyyy-mm-dd")
                    Next

                End With
            End If 'processing this one
        End If 'is a mail item
    Next objItem
End Sub

'return a filter for company and subject
Function PFilter(sCompany, sSubj)
    PFilter = "@SQL=""urn:schemas:httpmail:fromname"" LIKE '%@" & sCompany & "%'" & _
              "AND ""urn:schemas:httpmail:subject"" LIKE '%" & sSubj & "%'"
End Function

'Abstract out the rules for when a mail is processed
Function ProcessThisMail(theMail As Outlook.MailItem) As Boolean
    Dim iBackdate As Long
    If theMail.Attachments.Count > 0 Then
        Select Case Weekday(Now)
            Case 7: iBackdate = 3 ' Saturday: add extra day
            Case 1, 2, 3: iBackdate = 4 ' Sunday through Tuesday: add extra 2 days
            Case Else: iBackdate = 2 ' Other days
        End Select
        If theMail.ReceivedTime > DateAdd("d", -iBackdate, Now) Then
            ProcessThisMail = True 'will by default return false unless this line is reached
        End If
    End If
End Function

'ensure a subfolder exists
Sub EnsureSaveFolder(sPath As String)
    With CreateObject("scripting.filesystemobject")
        If Not .FolderExists(sPath) Then
            .CreateFolder sPath
        End If
    End With
End Sub
Добро пожаловать на сайт PullRequest, где вы можете задавать вопросы и получать ответы от других членов сообщества.

Похожие темы

...