excel - 从 Outlook 保存专门命名的 Excel 文件

Question

我需要保存一个专门的名称文件。

我的代码保存了第一个附件。我正在使用 Excel 2016 和 Outlook 2016。

问题是我的邮件有多个附件。

Sub SaveDownAttachment()
    Dim myOlApp As Outlook.Application
    Dim myInspector As Outlook.Inspector
    Dim myItem As Outlook.MailItem
    Dim myAttachments As Outlook.Attachments

    Dim Folder As Outlook.MAPIFolder
    Dim sFolders As Outlook.MAPIFolder
    Dim iRow As Long, oRow As Integer
    Dim MailBoxName As String, Pst_Folder_Name  As String
    Dim myname As String
    Dim Email As String

    myname = Application.UserName
    Email = Right(myname, Len(myname) - WorksheetFunction.Search(" ", myname)) & "." & Left(myname, WorksheetFunction.Search(",", myname) - 1) & "gmail.com"

    MailBoxName = Email

    Pst_Folder_Name = "Inbox"

    For Each Folder In Outlook.Session.Folders(MailBoxName).Folders
        If VBA.UCase(Folder.Name) = VBA.UCase(Pst_Folder_Name) Then GoTo Label_Folder_Found
        For Each sFolders In Folder.Folders
            If VBA.UCase(sFolders.Name) = VBA.UCase(Pst_Folder_Name) Then
                Set Folder = sFolders
                GoTo Label_Folder_Found
            End If
        Next sFolders
    Next Folder

Label_Folder_Found:
     If Folder.Name = "" Then
        MsgBox "Invalid Data in Input"
        GoTo End_Lbl1:
    End If

    On Error Resume Next

    For iRow = Folder.Items.Count To 1 Step -1
        If Folder.Items.Item(iRow).Subject = "Night Reporting" Then
            Set myOlApp = CreateObject("Outlook.Application")
            Set myItem = Folder.Items.Item(iRow)
            Set myAttachments = myItem.Attachments
            myAttachments.Item(3).SaveAsFile "S:\Luke\Night Report.xls"
            Exit Sub
        End If
    Next iRow

exitsub:        
    Set Folder = Nothing
    Set sFolders = Nothing

End_Lbl1:
End Sub

如果名称匹配，我将在哪里放置一个循环来保存文件？

标签： excelvbaoutlook

Answer 1

我想我自己已经得到了答案：

Sub SaveDownAttachment()

 Dim myOlApp As Outlook.Application
    Dim myInspector As Outlook.Inspector
    Dim myItem As Outlook.MailItem
     Dim Attachment As Attachment
    Dim myAttachments As Outlook.Attachments
    Dim i As Long



    Dim Folder As Outlook.MAPIFolder
    Dim sFolders As Outlook.MAPIFolder
    Dim iRow As Long, oRow As Integer
    Dim MailBoxName As String, Pst_Folder_Name  As String
    Dim myname As String
    Dim Email As String


   myname = Application.UserName
    Email = Right(myname, Len(myname) - WorksheetFunction.Search(" ", myname)) & "." & Left(myname, WorksheetFunction.Search(",", myname) - 1) & "@gmail.com"


    MailBoxName = Email


    Pst_Folder_Name = "Inbox"



    For Each Folder In Outlook.Session.Folders(MailBoxName).Folders
        If VBA.UCase(Folder.Name) = VBA.UCase(Pst_Folder_Name) Then GoTo Label_Folder_Found
        For Each sFolders In Folder.Folders
            If VBA.UCase(sFolders.Name) = VBA.UCase(Pst_Folder_Name) Then
                Set Folder = sFolders
                GoTo Label_Folder_Found
            End If
        Next sFolders
    Next Folder

Label_Folder_Found:
     If Folder.Name = "" Then
        MsgBox "Invalid Data in Input"
        GoTo End_Lbl1:
    End If
    On Error Resume Next

    For iRow = Folder.Items.Count To 1 Step -1

        If InStr(1, Folder.Items.Item(iRow).Subject, "Night Reporting") > 0 Then
        Set myOlApp = CreateObject("Outlook.Application")
        Set myItem = Folder.Items.Item(iRow)
        Set myAttachments = myItem.Attachments
            For i = 1 To myAttachments.Count
                If InStr(myAttachments.Item(i).fileName, "Night Report.xls") > 0 Then
                    myAttachments.Item(i).SaveAsFile ""S:\Luke\Night Report.xls""
             Exit For
                End If
             Next



                        Exit For



        End If
    Next iRow

End_Lbl1:
End Sub