从多个文件夹打开附件，复制内容并保存在“主文件"表中 [英] Open attachments from multiple folders, copy contents and save in Master File sheet

问题描述

此任务可以通过用户请求来实现，例如:

This task is achievable with user request such as:

FileToOpen = Application.GetOpenFilename(Filefilter:="Excel Files (*.xlsx), *.xlsx", Title:="Select 
Workbook to Import", MultiSelect:=True)

If IsArray(FileToOpen) Then           
    For FileCount = 1 To UBound(FileToOpen)
        shNewDat.Cells.Clear
        LastRow = shAll.Cells(Rows.Count, 1).End(xlUp).Row + 1 
        Set SelectedBook = Workbooks.Open(FileName:=FileToOpen(FileCount))
        SelectedBook.Worksheets("Sheet1").Cells.Copy    
        shNewDat.Range("A1").PasteSpecial xlPasteValuesAndNumberFormats

        SelectedBook.Close
        LastTempRow = shNewDat.Cells(Rows.Count, 2).End(xlUp).Row 'locate last row in the RAWData Temp tab

情况:
我要求用户不要与数据(通常是多个选择数据)进行交互.一旦将来自Outlook的附件下载到各自的文件夹中，我们就需要访问多个文件夹中的Excel文件(仅限于从Outlook下载的日期).然后，我需要循环遍历，将所有选定工作表的内容复制到一个Excel文件(Masterfile)中.第二天，应该继续进行，而不会从两天或更长时间(仅前一天)撤回附件/数据.

Situation:
I require that the user doesn't interact with data (manually multiple selecting data). We need to access Excel files in multiple folders (limited to the day of download from Outlook) to open as soon as attachments from Outlook have been downloaded into their respective folders. Then, I need to loop through to copy contents from all selected sheets to one Excel file (Masterfile). Following day, this should continue without attachment/data being pulled through from two days or more back (only the day before).

当前代码会从Outlook中提取附件，而我在这一点上陷入了困境.

Current code pulls attachments from Outlook and I'm stuck at this point.

我恳求我们遵守编码约定，以实现更清洁，更快的处理:

I would plead that we stick to the coding convention for cleaner faster processing:

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", "North", "compa  Report UpTo", "compa North Region Report"
ProcessMails objFolder, "compa", "South", "compa  Report UpTo", "compa South Region Report"
ProcessMails objFolder, "compa", "East", "compa  Report UpTo", "compa East Region Report"
ProcessMails objFolder, "compa", "West", "compa  Report UpTo", "compa West 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

推荐答案

类似以下内容:

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

    Const SUMMARY_WB As String = "C:\Path\ToYour\Summary\Workbook.xlsx"
    Dim saveAsFileName As String


    '...
    '...

    For Each objAttachment In .Attachments

        Debug.Print , "Attachment:", objAttachment.Filename
        saveAsFileName = dirFolderName & saveFileName & Format(objMailItem.ReceivedTime, "yyyy-mm-dd")

        objAttachment.SaveAsFile saveAsFileName
        CollectWorkbookInfo saveAsFileName, SUMMARY_WB      '<< collect info from the workbook you just saved

    Next

    '...
    '...

End Sub


Sub CollectWorkbookInfo(SourcePath As String, SummaryPath As String)
    Dim wbSrc As Workbook, wbSummary As Workbook

    Set wbSrc = Workbooks.Open(SourcePath)      'source
    Set wbSummary = Workbooks.Open(SummaryPath) 'destination
    '...
    '   do your copying between wbSrc and wbSummary
    '...
    wbSrc.Close False       'don't save
    wbSummary.Close True    'save

End Sub

这篇关于从多个文件夹打开附件，复制内容并保存在“主文件"表中的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！