进程选择而不是整个文件夹

时间:2013-11-11 23:20:27

标签: outlook-vba

参考下面的代码,我要做的不是处理整个文件夹,而只想处理我选择的电子邮件。 否则它完美无缺。

杰夫

需要以下参考资料:

  • Visual Basic for Applications
  • Microsoft Outlook 14.0对象库
  • OLE自动化
  • Microsoft Office 14.0对象库
  • Microsoft Shell控件和自动化

    Public Sub SaveOLFolderAttachments()
    
         ' Ask the user to select a file system folder for saving the attachments
         Dim oShell As Object
         Set oShell = CreateObject("Shell.Application")
         Dim fsSaveFolder As Object
         Set fsSaveFolder = oShell.BrowseForFolder(0, "Please Select a Save Folder:", 1)
         If fsSaveFolder Is Nothing Then Exit Sub
         ' Note:  BrowseForFolder doesn't add a trailing slash
    
         ' Ask the user to select an Outlook folder to process
         Dim olPurgeFolder As Outlook.MAPIFolder
         Set olPurgeFolder = Outlook.GetNamespace("MAPI").PickFolder
         If olPurgeFolder Is Nothing Then Exit Sub
    
         ' Iteration variables
         Dim msg As Outlook.MailItem
         Dim att As Outlook.Attachment
         Dim sSavePathFS As String
         Dim sDelAtts As String
    
         For Each msg In olPurgeFolder.Items
    
           sDelAtts = ""
    
           ' We check each msg for attachments as opposed to using .Restrict("[Attachment] > 0")
           ' on our olPurgeFolder.Items collection.  The collection returned by the Restrict method
           ' will be dynamically updated each time we remove an attachment.  Each update will
           ' reindex the collection.  As a result, it does not provide a reliable means for iteration.
           ' This is why the For Each style loops will not work. ~~
           If msg.Attachments.Count > 0 Then
    
             ' This While loop is controlled via the .Delete method which
             ' will decrement msg.Attachments.Count by one each time. ~~
             While msg.Attachments.Count > 0
    
               ' Save the attachment to the file system
               sSavePathFS = fsSaveFolder.Self.path & "\" & msg.Attachments(1).filename
               msg.Attachments(1).SaveAsFile sSavePathFS
    
               ' Build up a string to denote the file system save path(s)
               ' Format the string according to the msg.BodyFormat.
               If msg.BodyFormat <> olFormatHTML Then
                    sDelAtts = sDelAtts & vbCrLf & "<file://" & sSavePathFS & ">"
               Else
                    sDelAtts = sDelAtts & "<br>" & "<a href='file://" & sSavePathFS & "'>" & sSavePathFS & "</a>"
               End If
    
               ' Delete the current attachment.  We use a "1" here instead of an "i"
               ' because the .Delete method will shrink the size of the msg.Attachments
               ' collection for us.  Use some well placed Debug.Print statements to see
               ' the behavior. ~~
               msg.Attachments(1).Delete
    
              Wend
    
             ' Modify the body of the msg to show the file system location of
             ' the deleted attachments.
             If msg.BodyFormat <> olFormatHTML Then
                msg.Body = msg.Body & vbCrLf & vbCrLf & "Attachments Deleted:  " & Date & " " & Time & vbCrLf & vbCrLf & "Saved To:  " & vbCrLf & sDelAtts
             Else
                msg.HTMLBody = msg.HTMLBody & "<p></p><p>" & "Attachments Deleted:  " & Date & " " & Time & vbCrLf & vbCrLf & "Saved To:  " & vbCrLf & sDelAtts & "</p>"
             End If
    
              ' Save the edits to the msg.  If you forget this line, the attachments will not be deleted.  ~~
             msg.Save
    
            End If
    
          Next
    
    
    
    End Sub
    

1 个答案:

答案 0 :(得分:0)

删除选择器代码并首先选择项目。

'http://msdn.microsoft.com/en-us/library/office/aa171941(v=office.11).aspx

未经测试的代码

Sub SaveOLSelectedItemsAttachments()

Dim myOlExp As Outlook.Explorer
Dim myOlSel As Outlook.Selection
Dim x As Integer

Set myOlExp = Application.ActiveExplorer
Set myOlSel = myOlExp.Selection

' Ask the user to select a file system folder for saving the attachments
Dim oShell As Object
Set oShell = CreateObject("Shell.Application")
Dim fsSaveFolder As Object
Set fsSaveFolder = oShell.BrowseForFolder(0, "Please Select a Save Folder:", 1)
If fsSaveFolder Is Nothing Then Exit Sub
' Note:  BrowseForFolder doesn't add a trailing slash

For x = 1 To myOlSel.Count

    ' Iteration variables
    Dim att As Outlook.Attachment
    Dim sSavePathFS As String
    Dim sDelAtts As String

    Dim msg as mailitem
    Set msg = myOlSel.Item(x)

    sDelAtts = ""

    ' We check the item for attachments.
    ' The collection returned by the Restrict method
    ' will be dynamically updated each time we remove an attachment.  Each update will
    ' reindex the collection.  As a result, it does not provide a reliable means for iteration.
    ' This is why the For Each style loops will not work. ~~
    If msg.Attachments.Count > 0 Then

        ' This While loop is controlled via the .Delete method which
        ' will decrement msg.Attachments.Count by one each time. ~~
        While msg.Attachments.Count > 0

            ' Save the attachment to the file system
            sSavePathFS = fsSaveFolder.Self.path & "\" & msg.Attachments(1).filename
            msg.Attachments(1).SaveAsFile sSavePathFS

            ' Build up a string to denote the file system save path(s)
            ' Format the string according to the msg.BodyFormat.
            If msg.BodyFormat <> olFormatHTML Then
                sDelAtts = sDelAtts & vbCrLf & "<file://" & sSavePathFS & ">"
            Else
                sDelAtts = sDelAtts & "<br>" & "<a href='file://" & sSavePathFS & "'>" & sSavePathFS & "</a>"
            End If

            ' Delete the current attachment.  We use a "1" here instead of an "i"
            ' because the .Delete method will shrink the size of the msg.Attachments
            ' collection for us.  Use some well placed Debug.Print statements to see
            ' the behavior. ~~
            msg.Attachments(1).Delete

         Wend

         ' Modify the body of the msg to show the file system location of
         ' the deleted attachments.
         If msg.BodyFormat <> olFormatHTML Then
            msg.Body = msg.Body & vbCrLf & vbCrLf & "Attachments Deleted:  " & Date & " " & Time & vbCrLf & vbCrLf & "Saved To:  " & vbCrLf & sDelAtts
         Else
            msg.HTMLBody = msg.HTMLBody & "<p></p><p>" & "Attachments Deleted:  " & Date & " " & Time & vbCrLf & vbCrLf & "Saved To:  " & vbCrLf & sDelAtts & "</p>"
         End If

          ' Save the edits to the msg.  If you forget this line, the attachments will not be deleted.  ~~
         msg.Save

        End If

      Next

Next x

End Sub