VBA从Outlook下载附件

Question

下午好,

我正在努力寻找一种方法来实现以下项目：

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

但到目前为止，我只得到了一个错误'424‘- Object required on line：

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

上帝啊，亚历杭德罗，

尝试这个，对于我的工作，我尝试使用拆分字你的代码，但不好的工作，并找到这个解决方案，我只插入创建文件夹，重发是在网站上：Save attachments to a folder and rename them David e 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