Outlook inbox filter not working

[Cotton9]

The following code 'was' working on XP and stopped when upgraded to Win7. Suspect new Win7 security policy problem but then???

Win 7
Office 2007 SP3
Excel macro

I found examples to do this some time ago but can not locate the document or website anylonger.

The first cFilterSubject statment was working previously. The assignments following are various non-working attempts. They look OK but do not yield any results. Should return 8 outlook inBox items with respective attachments.
The intent is to move received turnaround reports, 54/month, from inbox to external data, .pst, file/folder.

<CODE>
'=======================================================
'=
'= Move sent items to P2 Turnaround Offline Folder
'=
'=======================================================

' Outlook constants not available in VBScript
Global Const PROPTAG As String = "

http://schemas.microsoft.com/mapi/proptag/"

Global Const PR_SUBJECT As String = "0x0037001E"
Global Const PR_HAS_ATTACH As String = "0x0E1B000B"

Global Const olFolderSentMail As Integer = 5

Public Const cPSTDisplayNameL As String = "P2-FY"
Public Const cPSTFolder As String = "TurnAroundReports"

' Win7
' Office 2007 SP3

Function Move_TAReport_Mail()


Dim cFilterSubject As String
Dim cFilterAttach As String
Dim cWkStr As String
Dim cPstFlNme As String

Dim dMonthNow As Varian

Dim oNs As Object ' NameSpace
Dim oInBox As Object ' MAPIFolder
Dim oOutBox As Object ' MAPIFolder
Dim oItem As Object
Dim oSrtItems As Object
Dim oSrtItemsA As Object
Dim olApp As Object

Dim nI As Integer

On Error GoTo read_completed_err

Set olApp = GetObject(, "Outlook.Application")
Set oNs = olApp.GetNamespace("MAPI")
Set oInBox = oNs.GetDefaultFolder(olFolderSentMail)

nI = 0

If oInBox.Items.Count = 0 Then
MsgBox "There are no messages in the Send Mail.", vbInformation, "Nothing Found"
Exit Sub
End If

If Month(Now()) >= 10 Then
''--- Adjust for next FY
cPstFlNme = Mid(Year(Now), 3, 2) + 1
Else
''--- Setup for current FY
cPstFlNme = Mid(Year(Now), 3, 2) + 0
End If

cPSTDisplayName = cPSTDisplayNameL & cPstFlNme

Set oOutBox = oNs.Folders(cPSTDisplayName).Folders(cPSTFolder)

On Error GoTo 0


' This was working but quit after OS upgraded from XP to Win7 --- maybe
cFilterSubject = "@SQL=" & Chr(34) & PROPTAG & PR_SUBJECT & _
Chr(34) & " like 'Project Turnaround Reports/Review%'"

' yields nothing
' cFilterSubject = "[Subject] = 'Project Turnaround Reports/Review'"

' from outlook SQL filter editor
' ("

http://schemas.microsoft.com/mapi/proptag/0x0037001f"

LIKE '%''Project%'
' AND "

http://schemas.microsoft.com/mapi/proptag/0x0037001f"

LIKE '%Turnaround%'
' AND "

http://schemas.microsoft.com/mapi/proptag/0x0037001f"

LIKE '%Reports/Review%')

' this is one long line. does not error out but return nothing
cFilterSubject = _
"(""

http://schemas.microsoft.com/mapi/proptag/0x0037001f""

LIKE '%''Project%' AND ""

http://schemas.microsoft.com/mapi/proptag/0x0037001f""

LIKE '%Turnaround%' AND ""

http://schemas.microsoft.com/mapi/proptag/0x0037001f""

LIKE '%Reports/Review%')"



'cWkStr = Chr(34) & PROPTAG & PR_SUBJECT & Chr(34) & " LIKE " & Chr(39)
'cFilterSubject = cWkStr & "%" & Chr(39) & Chr(39) & "Project%" & Chr(39)


' on microsoft website it shows subject as 0x0037001E but outlook shows 0x0037001F
'cFilterSubject = Replace(cFilterSubject, "1E", "1F")

'cFilterSubject = "@SQL=" & cFilterSubject



cFilterAttach = "@SQL=" & Chr(34) & PROPTAG & PR_HAS_ATTACH & _
Chr(34) & " = 1"
' Debug.Print "Subject: " & cFilterSubject & vbCrLf & "Attachments: " & cFilterAttach

Set oSrtItems = oInBox.Items.Restrict(cFilterSubject)
'Debug.Print "Subj Filter Count: " & oSrtItems.Count

Set oSrtItemsA = oSrtItems.Restrict(cFilterAttach)
Debug.Print "Subj Filter Count: " & oSrtItems.Count & vbCrLf & "Attachments Count: " & oSrtItemsA.Count

Stop

If oSrtItemsA.Count > 0 Then
'cPSTDisplayName = cPSTDisplayNameL & cPstFlNme
'Set oOutBox = oNs.Folders(cPSTDisplayName).Folders(cPSTFolder)

For Each oItem In oSrtItemsA ' .Items

oItem.Move oOutBox
'Debug.Print oItem.Subject; " : -> To Be Moved."
nI = nI + 1

Next
End If

read_completed_exit:
Set oSrtItemsA = Nothing
Set oSrtItems = Nothing
Set oItem = Nothing
Set oInBox = Nothing
Set oNs = Nothing
' Move_TAReport_mail = True
Exit Function

read_completed_err:
MsgBox "An unexpeced error has occurred." & _
vbCrLf & "Please note and report the following error." & _
vbCrLf & "Macro Name: Move_TAReport_Mail()" & _
vbCrLf & "Error number: " & Err.Number & _
vbCrLf & "Error Description: " & Err.Description, vbCritical, "Error!"

Resume read_completed_exit

End Function
''--- EOS Move_TAReport_Mail()

</CODE>

D. Buckman
US Army Corps of Engineers, Omaha

Learn from the past, Live in the present, Create the future

 

[Cotton9]

Found the major problem. After we were force to change the send method for outlook to an external SMTP utility.
<code>
'Set oInBox = oNs.GetDefaultFolder(olFolderSentbox
' line was not changed to
Set oInBox = oNs.GetDefaultFolder(olFolderInbox)</code>

With that minor change all three cFilterSubject lines now work.
<code>
'cFilterSubject = "@SQL=" & Chr(34) & PROPTAG & PR_SUBJECT & _
Chr(34) & " like 'Project Turnaround Reports/Review%'"
'cFilterSubject = "@SQL=" & PROPTAG & PR_SUBJECT & " like 'Project Turnaround%'"
cFilterSubject = "[Subject] = 'Project Turnaround Reports/Review'"
</code>

The old adage still works. When something breaks think about what you last changed -- then think about it's side effects.


D. Buckman
US Army Corps of Engineers, Omaha

Learn from the past, Live in the present, Create the future