VBA 从 Outlook 下载附件

Question

下午好，

我正在尝试找到一种方法来实现以下项目：

当我收到一封带有附件且主题中有特定单词的电子邮件时，请创建一个文件夹并将附件下载到该文件夹​​。

但到目前为止，我只收到一个错误“424” - 需要在线对象：

If TypeName(olMail) = "Mailterm" And myMail.Subject Like "*" & "prueba" & "*" And olMail.Attachments.Count > 0 Then

如果我删除该部分：

And myMail.Subject Like "*" & "prueba" & "*"

然后再次运行，错误消失了，但是我得到一个错误：

运行时错误“13”： 类型不匹配

突出显示：

Next olMail

我不是 VBA 方面的专家，但如果您能帮助我，我们将不胜感激。

    Option Explicit

    Sub Download_Attachments()

    Dim ns As NameSpace
    Dim olFolder_Inbox As Folder
    Dim olMail As Object
    Dim olAttachment As Attachment
    
    Dim fso As Object
    Dim File_Saved_Folder_Path As String
    
    Dim sFolderName As String
    sFolderName = Format(Now, "yyyyMMdd")
    
    File_Saved_Folder_Path = "C:\Users\agonzalezp\Documents\prueba" & "\" & sFolderName
    
    Set ns = GetNamespace("MAPI")
    Set olFolder_Inbox = ns.GetDefaultFolder(olFolderInbox)
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    For Each olMail In olFolder_Inbox.Items
        
       If TypeName(olMail) = "MailItem" Then
        
        If olMail.Subject Like "*" & "prueba" & "*" Then 'And olMail.Attachments.Count > 0
    
            fso.CreateFolder (File_Saved_Folder_Path)
    
            For Each olAttachment In olMail.Attachments
    
               Select Case UCase(fso.GetExtensionName(olAttachment.FileName))
    
                    Case "XLSX", "XLSM"
                        olAttachment.SaveAsFile (File_Saved_Folder_Path)
                        
               End Select
    
            Next olAttachment
         End If
       End If
    
    Next olMail
    
    Set olFolder_Inbox = Nothing
    Set ns = Nothing

    Set fso = Nothing

End Sub

Answer 1

上帝啊，亚历杭德罗，

试试这个，对我来说工作，我尝试使用拆分词你的代码但效果不好，找到这个解决方案，我只插入创建文件夹，respost 在现场： Save attachments to a folder and rename themDavide jogold

Public Sub Download_Attachments()
'If execute in excel, for sample.
'ADD 'Tools > References... Microsoft Outlook 16.0 Object Library
On Error GoTo Err_Control
Dim OutlookOpened As Boolean
Dim outApp As Outlook.Application
Dim outNs As Outlook.Namespace
Dim outFolder As Outlook.MAPIFolder
Dim outAttachment As Outlook.attachment
Dim outItem As Object
Dim saveFolder As String
Dim outMailItem As Outlook.MailItem
Dim inputDate As String, subjectFilter As String, sFolderName As String
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")

sFolderName = Format(Now, "yyyyMMdd")
saveFolder = "C:\DOCUMENTOS\Outlook_Anexos" & "\" & sFolderName     'REPLACE YOUR PATCH
If Right(saveFolder, 1) <> "\" Then saveFolder = saveFolder & "\"

subjectFilter = ("Aplicaciones")    'REPLACE WORD SUBJECT TO FIND

OutlookOpened = False
On Error Resume Next
Set outApp = GetObject(, "Outlook.Application")
If Err.Number <> 0 Then
    Set outApp = New Outlook.Application
    OutlookOpened = True
End If
On Error GoTo Err_Control

If outApp Is Nothing Then
    MsgBox "Cannot start Outlook.", vbExclamation
    Exit Sub
End If

Set outNs = outApp.GetNamespace("MAPI")
Set outFolder = outNs.GetDefaultFolder(olFolderInbox)

If Not outFolder Is Nothing Then
    For Each outItem In outFolder.Items
        If outItem.Class = Outlook.OlObjectClass.olMail Then
            Set outMailItem = outItem
                If InStr(1, outMailItem.Subject, subjectFilter) > 0 Then 'removed the quotes around subjectFilter
                    For Each outAttachment In outMailItem.Attachments
                    If Dir(saveFolder, vbDirectory) = "" Then fso.CreateFolder (saveFolder)
                        outAttachment.SaveAsFile saveFolder & outAttachment.Filename
                    Set outAttachment = Nothing
                    Next
                End If
        End If
    Next
End If

If OutlookOpened Then outApp.Quit
Set outApp = Nothing
Err_Control:
If Err.Number <> 0 Then
    MsgBox Err.Description
End If
End Sub

Answer 2

下午好，胡里奥·加迪奥利·苏亚雷斯，

我已经尝试了您提供的代码，它确实有效，但与我预期的不同。

我已成功下载文件，但没有权限问题，但文件并未保存在先前创建的文件夹内，而是保存在外部。

另外，他们的名字也改了。

Public Sub Download_Attachments()
'If execute in excel, for sample.
'ADD 'Tools > References... Microsoft Outlook 16.0 Object Library
On Error GoTo Err_Control
Dim OutlookOpened As Boolean
Dim outApp As Outlook.Application
Dim outNs As Outlook.NameSpace
Dim outFolder As Outlook.MAPIFolder
Dim outAttachment As Outlook.Attachment
Dim outItem As Object
Dim saveFolder As String
Dim outMailItem As Outlook.MailItem
Dim inputDate As String, subjectFilter As String, sFolderName As String
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")

sFolderName = Format(Now, "yyyyMMdd")
    
saveFolder = "C:\Users\agonzalezp\Documents\prueba" & "\" & sFolderName

subjectFilter = ("NUEVA")    'REPLACE WORD SUBJECT TO FIND

OutlookOpened = False
On Error Resume Next
Set outApp = GetObject(, "Outlook.Application")
If Err.Number <> 0 Then
    Set outApp = New Outlook.Application
    OutlookOpened = True
End If
On Error GoTo Err_Control

If outApp Is Nothing Then
    MsgBox "Cannot start Outlook.", vbExclamation
    Exit Sub
End If

Set outNs = outApp.GetNamespace("MAPI")
Set outFolder = outNs.GetDefaultFolder(olFolderInbox)

If Not outFolder Is Nothing Then
    For Each outItem In outFolder.Items
        If outItem.Class = Outlook.OlObjectClass.olMail Then
            Set outMailItem = outItem
                If InStr(1, outMailItem.Subject, subjectFilter) > 0 Then 'removed the quotes around subjectFilter
                    For Each outAttachment In outMailItem.Attachments
                    If Dir(saveFolder, vbDirectory) = "" Then fso.CreateFolder (saveFolder)
                        outAttachment.SaveAsFile saveFolder & outAttachment.FileName
                    Set outAttachment = Nothing
                    Next
                End If
        End If
    Next
End If

If OutlookOpened Then outApp.Quit
Set outApp = Nothing
Err_Control:
If Err.Number <> 0 Then
    MsgBox Err.Description
End If
End Sub

Answer 3

感谢大家的合作和帮助。

最后代码一直工作如下：

Public Sub Download_Attachments()
'If execute in excel, for sample.
'ADD 'Tools > References... Microsoft Outlook 16.0 Object Library
On Error GoTo Err_Control
Dim OutlookOpened As Boolean
Dim outApp As Outlook.Application
Dim outNs As Outlook.Namespace
Dim outFolder As Outlook.MAPIFolder
Dim outAttachment As Outlook.Attachment
Dim outItem As Object
Dim DestinationFolderName As String
Dim saveFolder As String
Dim outMailItem As Outlook.MailItem
Dim inputDate As String, subjectFilter As String, sFolderName As String
Dim FSO As Object
Dim SourceFileName As String, DestinFileName As String
Set FSO = CreateObject("Scripting.FileSystemObject")
Set FSO = CreateObject("Scripting.Filesystemobject")

sFolderName = Format(Now, "yyyyMMdd")
sMailName = Format(Now, "dd/MM/yyyy")

DestinationFolderName = "C:\Users\agonzalezp\Documents\Automatizaciones"
    
saveFolder = DestinationFolderName & "\" & sFolderName

subjectFilter = "NUEVA" & " " & sMailName    'REPLACE WORD SUBJECT TO FIND

OutlookOpened = False
On Error Resume Next
Set outApp = GetObject(, "Outlook.Application")
If Err.Number <> 0 Then
    Set outApp = New Outlook.Application
    OutlookOpened = True
End If
On Error GoTo Err_Control

If outApp Is Nothing Then
    MsgBox "Cannot start Outlook.", vbExclamation
    Exit Sub
End If

Set outNs = outApp.GetNamespace("MAPI")
Set outFolder = outNs.GetDefaultFolder(olFolderInbox)

If Not outFolder Is Nothing Then
    For Each outItem In outFolder.Items
        If outItem.Class = Outlook.OlObjectClass.olMail Then
            Set outMailItem = outItem
                If InStr(1, outMailItem.Subject, subjectFilter) > 0 Then 'removed the quotes around subjectFilter
                    For Each outAttachment In outMailItem.Attachments
                    If Dir(saveFolder, vbDirectory) = "" Then FSO.CreateFolder (saveFolder)
                        outAttachment.SaveAsFile saveFolder & " - " & outAttachment.fileName
                    Set outAttachment = Nothing
                    Next
                End If
        End If
    Next
End If


    SourceFileName = "C:\Users\agonzalezp\Documents\Automatizaciones\*.xlsx"
    DestinFileName = saveFolder

    FSO.MoveFile SourceFileName, DestinFileName

If OutlookOpened Then outApp.Quit
Set outApp = Nothing
Err_Control:
If Err.Number <> 0 Then
    'MsgBox Err.Description
End If
End Sub