VBA用于从具有多个帐户的电子邮件中保存附件(基于定义的标准) [英] VBA to save attachments (based on defined criteria) from an email with multiple accounts

问题描述

情况:我有一个代码，在输入了发件人电子邮件的情况下，将从Outlook电子邮件中下载所有附件(如果发件人是指定的发件人，则会保存.xls附件). /p>

问题1:在我看来，我可以使用2个帐户(分别是个人帐户和公共帐户).我希望能够从这些帐户中选择代码应下载的附件.

问题1:是否可以进行这种选择?从以前的研究中，我能够找到有关附件类型的标准，还有更多，但是对于多个收件箱却找不到.

问题2:在第二个收件箱(公共)的附件中，我只想选择具有带有特定名称"的工作表的文件.我知道如何解决这个问题，但是不知道是否有可能读取该文件(并检查它是否有想要的工作表)，然后再下载它.

问题2:我可以访问这样的文件吗?可以进行这种标准检查吗?

到目前为止的

代码:

Sub email()

Application.ScreenUpdating = False

On Error Resume Next

Dim olApp As New Outlook.Application
Dim olNameSpace As Object
Dim olMailItem As Outlook.MailItem
Dim olFolder As Object
Dim olFolderName As String
Dim olAtt As Outlook.Attachments
Dim strName As String
Dim sPath As String
Dim i As Long
Dim j As Integer
Dim olSubject As String
Dim olSender As String
Dim sh As Worksheet
Dim LastRow As Integer

ThisWorkbook.Worksheets("FileNames").Rows(2 & ":" & ThisWorkbook.Worksheets("FileNames").Rows.count).Delete

olFolderName = ThisWorkbook.Worksheets("Control").Range("D10")
olSender = ThisWorkbook.Worksheets("Control").Range("D16")

sPath = Application.FileDialog(msoFileDialogFolderPicker).Show
sPathstr = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1)

Set olNameSpace = olApp.GetNamespace("MAPI")

'check if folder is subfolder or not and choose olFolder accordingly
Set olFolder = olNameSpace.GetDefaultFolder(olFolderInbox).Folders(olFolderName)
If (olFolder = "") Then
    Set olFolder = olNameSpace.GetDefaultFolder(olFolderInbox).Parent.Folders(olFolderName)
End If

'loop through mails
h = 2
For i = 1 To olFolder.Items.count
    Set olMailItem = olFolder.Items(i)

    If (InStr(1, olMailItem.SenderEmailAddress, olSender, vbTextCompare) <> 0) Then

        With olMailItem

            'loop through attachments
            For j = 1 To .Attachments.count

                strName = .Attachments.Item(j).DisplayName

                'check if file already exists
                If Not Dir(sPathstr & "\" & strName) = "" Then
                .Attachments(j).SaveAsFile sPathstr & "\" & "(1)" & strName
                ThisWorkbook.Worksheets("FileNames").Range("A" & h) = "(1)" & strName
                Else
                .Attachments(j).SaveAsFile sPathstr & "\" & strName
                ThisWorkbook.Worksheets("FileNames").Range("A" & h) = strName
                End If

                h = h + 1
            Next

        End With

    End If
Next

Application.ScreenUpdating = True
MsgBox "Download complete!", vbInformation + vbOKOnly, "Done"

End Sub

解决方案

Outlook中的每个文件夹都有唯一的路径.即使它们都被称为收件箱"，它们的路径也不同.选择Outlook中的第一个收件箱，然后转到立即窗口(Alt + F11，然后按Ctrl + G).输入此内容，然后按Enter

?application.ActiveExplorer.CurrentFolder.FolderPath

您会得到类似的东西

\\[e-mail]\Inbox

现在返回Outlook并选择其他收件箱".返回立即窗口并执行相同的命令.现在，您将拥有每个收件箱的路径.也许第二个看起来像

\\DKPersonal\Inbox

您使用GetDefaultFolder，这非常方便.但是，您可以通过直接遵循其路径来访问任何文件夹，甚至是默认文件夹.

Set olFolder = Application.GetNamespace("MAPI").Folders("[e-mail]").Folders("Inbox")

只需将Folders个属性链接在一起，直到获得所需的属性即可.

对于问题2，您无法在不打开Excel文件的情况下对其进行检查.您必须将其下载到一个临时位置，将其打开以查看其是否包含工作表，然后将其移至最终位置.或将其下载到最终位置，如果没有工作表，则将其删除.

Situation: I have a code that, given an input of sender email, will download all attachments from outlook email (if the sender is the one specified, it saves the .xls attachments).

Problem 1: In my outlook, I have access to 2 accounts (lets say personal and public). I want to be able to select from which of those accounts the code should download the attachments.

Question 1: Is it possible to do this kind of selection? From previous research I was able to find criteria regarding the type of attachments, and more, but nothing regarding multiple inboxes.

Problem 2: Among the attachments in this second inbox (public) I want to select only the files which have a worksheet with a certain "NAME". I know how to do an if to account for that, but don't know if its possible to read the file (and check if it has the wanted sheet) and only then download it.

Question 2: Could I access a file like this? Would it be possible to do this kind of criteria check?

Code so far:

Sub email()

Application.ScreenUpdating = False

On Error Resume Next

Dim olApp As New Outlook.Application
Dim olNameSpace As Object
Dim olMailItem As Outlook.MailItem
Dim olFolder As Object
Dim olFolderName As String
Dim olAtt As Outlook.Attachments
Dim strName As String
Dim sPath As String
Dim i As Long
Dim j As Integer
Dim olSubject As String
Dim olSender As String
Dim sh As Worksheet
Dim LastRow As Integer

ThisWorkbook.Worksheets("FileNames").Rows(2 & ":" & ThisWorkbook.Worksheets("FileNames").Rows.count).Delete

olFolderName = ThisWorkbook.Worksheets("Control").Range("D10")
olSender = ThisWorkbook.Worksheets("Control").Range("D16")

sPath = Application.FileDialog(msoFileDialogFolderPicker).Show
sPathstr = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1)

Set olNameSpace = olApp.GetNamespace("MAPI")

'check if folder is subfolder or not and choose olFolder accordingly
Set olFolder = olNameSpace.GetDefaultFolder(olFolderInbox).Folders(olFolderName)
If (olFolder = "") Then
    Set olFolder = olNameSpace.GetDefaultFolder(olFolderInbox).Parent.Folders(olFolderName)
End If

'loop through mails
h = 2
For i = 1 To olFolder.Items.count
    Set olMailItem = olFolder.Items(i)

    If (InStr(1, olMailItem.SenderEmailAddress, olSender, vbTextCompare) <> 0) Then

        With olMailItem

            'loop through attachments
            For j = 1 To .Attachments.count

                strName = .Attachments.Item(j).DisplayName

                'check if file already exists
                If Not Dir(sPathstr & "\" & strName) = "" Then
                .Attachments(j).SaveAsFile sPathstr & "\" & "(1)" & strName
                ThisWorkbook.Worksheets("FileNames").Range("A" & h) = "(1)" & strName
                Else
                .Attachments(j).SaveAsFile sPathstr & "\" & strName
                ThisWorkbook.Worksheets("FileNames").Range("A" & h) = strName
                End If

                h = h + 1
            Next

        End With

    End If
Next

Application.ScreenUpdating = True
MsgBox "Download complete!", vbInformation + vbOKOnly, "Done"

End Sub

解决方案

Every folder in Outlook has a unique path. Even if they're both called Inbox, the path to them is different. Select the first Inbox in Outlook and go to the Immediate Window (Alt+F11 then Ctrl+G). Type this and press enter

?application.ActiveExplorer.CurrentFolder.FolderPath

You'll get something like

\\[e-mail]\Inbox

Now go back to Outlook and select the other Inbox. Return to the Immediate Window and execute the same command. Now you'll have the path to each Inbox. Maybe the second one looks like

\\DKPersonal\Inbox

You use GetDefaultFolder, which is very handy. But you can get to any folder, even default folders, by following their path directly.

Set olFolder = Application.GetNamespace("MAPI").Folders("[e-mail]").Folders("Inbox")

Just chain Folders properties together until you get to the one you want.

As for Question 2, you can't inspect an Excel file without opening it. You'll have to download it to a temporary location, open it to see if it contains the worksheet, and move it to the final location if it does. Or download it to the final location and delete it if it doesn't have the sheet.

这篇关于VBA用于从具有多个帐户的电子邮件中保存附件(基于定义的标准)的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！