2016-02-19 38 views
2

我正在使用一個腳本來打開電子郵件並下載它的附件。現在,我可以選擇下載的最新電子郵件最近附件:使用兩個過濾器的Outlook .items.restrict

Sub CTEmailAttDownload() 

Const olFolderInbox As Integer = 6 
'~~> Path for the attachment 
Const AttachmentPath As String = "C:\TEMP\TestExcel" 

    Dim oOlAp As Object 
    Dim oOlns As Object 
    Dim oOlInb As Object 
    Dim oOlItm As Object 
    Dim oOlAtch As Object 
    Dim oOlResults As Object 

    Dim x As Long 

    Dim NewFileName As String 
    NewFileName = "Daily Tracker " & Format(Now, "dd-MM-yyyy") 

    'You can only have a single instance of Outlook, so if it's already open 
    'this will be the same as GetObject, otherwise it will open Outlook. 
    Set oOlAp = CreateObject("Outlook.Application") 
    Set oOlns = oOlAp.GetNamespace("MAPI") 
    Set oOlInb = oOlns.GetDefaultFolder(olFolderInbox) 

    'No point searching the whole Inbox - just since yesterday. 
    Set oOlResults = oOlInb.Items.Restrict("[ReceivedTime]>'" & Format(Date - 1, "DDDDD HH:NN") & "'") 

    'If you have more than a single attachment they'll all overwrite each other. 
    'x will update the filename. 
    x = 1 
    For Each oOlItm In oOlResults 
     If oOlItm.Attachments.Count > 0 Then 
      For Each oOlAtch In oOlItm.Attachments 
       If GetExt(oOlAtch.FileName) = "xlsx" Then 
        oOlAtch.SaveAsFile AttachmentPath & "\" & NewFileName & ".xlsx" 
       End If 
       x = x + 1 
      Next oOlAtch 
     End If 
    Next oOlItm 

End Sub 

'---------------------------------------------------------------------- 
' GetExt 
' 
' Returns the extension of a file. 
'---------------------------------------------------------------------- 
Public Function GetExt(FileName As String) As String 

    Dim mFSO As Object 
    Set mFSO = CreateObject("Scripting.FileSystemObject") 

    GetExt = mFSO.GetExtensionName(FileName) 
End Function 

通過使用'[Subject] ='我可以按主題下載。

我的問題是,我怎麼能把這兩個過濾器放在一起,所以我可以過濾主題和ReceivedTime?

我試圖與,&+將它們結合在一起,至今我還沒有成功。

+1

怎麼樣再次限制'oOlResults'。像在第一個「Set oOlResults」下設置oOlResults = oOlResults.Items.Restrict(「[Subject] ='」&mySubject)'?您也可以將它添加到If語句'如果您的安裝。計數> 0並且oOlItm.Subject = mySubject'。 –

回答

0
@SQL=(Subject LIKE '%blah%') AND (ReceivedTime > '01/02/2015') 
+0

嗨,德米特里。我會在哪裏放?在這種情況下,它不會計算它是從最後一天的電子郵件。 –

+0

您可以將該過濾器傳遞給Items.Restrict以獲取受限於兩個條件的集合 - 主題和收到日期。 –

0

即使得到一個限制的語法也很困難。正如Scott Holtzman的評論所指出的那樣,如果您分開了解每個過濾器,則可以過濾兩次。

Option Explicit 

Sub CTEmailAttDownload() 

    Const olFolderInbox As Integer = 6 
    '~~> Path for the attachment 
    Const AttachmentPath As String = "C:\TEMP\TestExcel" 

    Dim oOlAp As Object 
    Dim oOlns As Object 
    Dim oOlInb As Object 

    Dim oOlItm As Object 
    Dim oOlAtch As Object 

    Dim oOlResults As Object 
    Dim oOlSubjectResults As Object 
    Dim strFilter As String 
    Dim i As Long 

    Dim x As Long 

    Dim NewFileName As String 
    NewFileName = "Daily Tracker " & format(Now, "dd-MM-yyyy") 

    'You can only have a single instance of Outlook, so if it's already open 
    'this will be the same as GetObject, otherwise it will open Outlook. 
    Set oOlAp = CreateObject("Outlook.Application") 
    Set oOlns = oOlAp.GetNamespace("MAPI") 
    Set oOlInb = oOlns.GetDefaultFolder(olFolderInbox) 

    'No point searching the whole Inbox - just since yesterday. 
    Set oOlResults = oOlInb.Items.Restrict("[ReceivedTime]>'" & format(Date - 1, "DDDDD HH:NN") & "'") 

    strFilter = "@SQL=" & Chr(34) & "urn:schemas:httpmail:subject" & Chr(34) & " like '%test%'" 

    Set oOlSubjectResults = oOlResults.Restrict(strFilter) 

    If oOlSubjectResults.count = 0 Then 
     Debug.Print "No emails found with applicable subject" 

    Else 
     'If you have more than a single attachment they'll all overwrite each other. 
     'x will update the filename. 
     x = 1 

     For i = 1 To oOlSubjectResults.count 
      Set oOlItm = oOlSubjectResults(i) 
      If oOlItm.Attachments.count > 0 Then 
       Debug.Print oOlItm.Subject 
       For Each oOlAtch In oOlItm.Attachments 

        Debug.Print oOlAtch.DisplayName 

        If GetExt(oOlAtch.FileName) = "xlsx" Then 
         oOlAtch.SaveAsFile AttachmentPath & "\" & NewFileName & ".xlsx" 
        End If 
        x = x + 1 
       Next oOlAtch 
      End If 
     Next i 
    End If 

ExitRoutine: 
    Set oOlAp = Nothing 
    Set oOlns = Nothing 
    Set oOlInb = Nothing 

    Set oOlResults = Nothing 
    Set oOlSubjectResults = Nothing 

End Sub 
+0

嗨,@niton。我很抱歉,但我現在只需要再次處理這個問題。使用這個確切的代碼,我不能讓它打開Outlook 2013。我檢查了參考文獻,似乎我有合適的庫。你知道會發生什麼嗎? –