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/0x003700..." LIKE '%''Project%'
' AND "http://schemas.microsoft.com/mapi/proptag/0x003700..." LIKE '%Turnaround%'
' AND "http://schemas.microsoft.com/mapi/proptag/0x003700..." LIKE '%Reports/Review%')

' this is one long line. does not error out but return nothing
cFilterSubject = _
"(""http://schemas.microsoft.com/mapi/proptag/0x003700..."" LIKE '%''Project%' AND ""http://schemas.microsoft.com/mapi/proptag/0x003700..."" LIKE '%Turnaround%' AND ""http://schemas.microsoft.com/mapi/proptag/0x003700..."" 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

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