☰

宏可将电子邮件中的所有 Excel 附件保存到我的硬盘文件夹中

tag-icon • tag-icon microsoft-outlook vba macros
宏可将电子邮件中的所有 Excel 附件保存到我的硬盘文件夹中

下面是一个有效的代码，它将把 Outlook 电子邮件上的所有附件保存到硬盘上的特定文件夹中。要使它工作，我必须选择我希望宏在其中运行的所有电子邮件。我需要的帮助是修改代码以在我的 Outlook 上的特定文件夹中运行，而无需我手动选择电子邮件，然后它会将所有 excel 附件保存到硬盘上的文件夹中。我尝试了一些方法，但有一次它将所有附件转换为 excel 文件，而不是仅提取 excel 文件并忽略其他任何内容。

Public Sub SaveAttachments()
Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem
Dim objAttachments As Outlook.Attachments
Dim objSelection As Outlook.Selection
Dim i As Long
Dim lngCount As Long
Dim strFile As String
Dim strFolderpath As String
Dim strDeletedFiles As String

strFolderpath = "F:\Test folder"
On Error Resume Next

Set objOL = CreateObject("Outlook.Application")

Set objSelection = objOL.ActiveExplorer.Selection

strFolderpath = strFolderpath & "\Attachments\"


For Each objMsg In objSelection


    Set objAttachments = objMsg.Attachments
    lngCount = objAttachments.Count
    strDeletedFiles = ""

    If lngCount > 0 Then


        For i = lngCount To 1 Step -1


            strFile = objAttachments.Item(i).FileName
            strFile = strFolderpath & strFile
            objAttachments.Item(i).SaveAsFile strFile
            objAttachments.Item(i).Delete
            If objMsg.BodyFormat <> olFormatHTML Then
                strDeletedFiles = strDeletedFiles & vbCrLf & "<file://" & strFile & ">"
            Else
                strDeletedFiles = strDeletedFiles & "<br>" & "<a href='file://" & _
                strFile & "'>" & strFile & "</a>"
            End If


        Next i


        If objMsg.BodyFormat <> olFormatHTML Then
            objMsg.Body = vbCrLf & "The file(s) were saved to " & strDeletedFiles & vbCrLf & objMsg.Body
        Else
            objMsg.HTMLBody = "<p>" & "The file(s) were saved to " & strDeletedFiles & "</p>" & objMsg.HTMLBody
        End If
        objMsg.Save
    End If
Next

ExitSub:

Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
End Sub

答案1

要仅保存 Excel 附件，请检查扩展名。

Public Sub SaveAttachments()

'Dim objOL As Outlook.Application
'Dim objMsg As Outlook.mailitem
'Dim objAttachments As Outlook.Attachments
'Dim objSelection As Outlook.Selection

Dim objMsg As Object    ' Accepts anything in the selection
Dim objAttachments As Attachments
Dim objSelection As Selection

Dim i As Long
Dim lngCount As Long

Dim strFile As String
Dim strFolderpath As String
Dim strDeletedFiles As String

strFolderpath = "F:\Test folder"

'On Error Resume Next
' The On Error Resume Next means
'  if the "Attachments" folder does not exist
'  the attachments will be lost forever when deleted.

'Set objOL = CreateObject("Outlook.Application")
'Set objSelection = objOL.ActiveExplorer.Selection

Set objSelection = ActiveExplorer.Selection

strFolderpath = strFolderpath & "\Attachments\"

For Each objMsg In objSelection

    If objMsg.Class = olMail Then

        Set objAttachments = objMsg.Attachments
        lngCount = objAttachments.count
        strDeletedFiles = ""

        If lngCount > 0 Then

            For i = lngCount To 1 Step -1

                strFile = objAttachments.Item(i).fileName

                If strFile Like "*.xls*" Then

                    strFile = strFolderpath & strFile

                    objAttachments.Item(i).SaveAsFile strFile

                    objAttachments.Item(i).Delete

                    If objMsg.BodyFormat <> olFormatHTML Then
                        strDeletedFiles = strDeletedFiles & vbCrLf & "<file://" & strFile & ">"
                    Else
                        strDeletedFiles = strDeletedFiles & "<br>" & "<a href='file://" & _
                        strFile & "'>" & strFile & "</a>"
                    End If

                End If

            Next i

            If objMsg.BodyFormat <> olFormatHTML Then
                objMsg.body = vbCrLf & "The file(s) were saved to " & strDeletedFiles & vbCrLf & objMsg.body
            Else
                objMsg.HTMLBody = "<p>" & "The file(s) were saved to " & strDeletedFiles & "</p>" & objMsg.HTMLBody
            End If

            ' Verify working then switch from Display to Save
            objMsg.Display
            'objMsg.Save

        End If

    End If

Next

ExitSub:

    Set objAttachments = Nothing
    Set objMsg = Nothing
    Set objSelection = Nothing
    'Set objOL = Nothing

End Sub

在文件夹而不是选择上运行是一个单独的问题。

相关内容