OL2003: Get Mail items from Folder

[aconybeare]

Hi,

I'm trying to permanently delete items from a mail folder see below for what I have so far

At the moment I have to loop through each message in the deleted folder. Is there a way of just getting messages with a specific category/ies?

Option Explicit
 
' To use the Alerts and helpdesk functions you must create two categories
' "NetworkAlert" and "HelpDesk". These are used to mark the messages, so we can just delete
' the specific messages.
 
Sub Alerts()
    Dim nmsName As Outlook.NameSpace: Set nmsName = Application.GetNamespace("MAPI")
    Dim fldPFolder As Outlook.MAPIFolder: Set fldPFolder = nmsName.GetDefaultFolder(olFolderInbox).Parent
    Dim sTPath As String: sTPath = "Alerts"
    Dim oFolder As Outlook.MAPIFolder: Set oFolder = getFolder(sTPath, fldPFolder)
    Dim oMail As Outlook.MailItem
    Dim bDoPermDel As Boolean: bDoPermDel = False
    
    For Each oMail In oFolder.Items
        oMail.UnRead = False
        oMail.Categories = "NetworkAlert"
        oMail.Save
        oMail.Delete
        DoEvents
        bDoPermDel = True
    Next
 
    If bDoPermDel = True Then
        Call PermanentlyDelete("NetworkAlert")
    End If
            
    Set oMail = Nothing
    Set oFolder = Nothing
    Set fldPFolder = Nothing
    Set nmsName = Nothing
End Sub
 
Function getFolder(ByVal ssPath As String, PFolder As MAPIFolder) As MAPIFolder
    Dim fldFolder As Outlook.MAPIFolder
    Dim thisLevel
    Dim nextLevel
    Dim t As Integer: t = InStr(ssPath, "\")
    If t = 0 Then
        thisLevel = ssPath
    Else
        thisLevel = Left(ssPath, t - 1)
        nextLevel = Mid(ssPath, t + 1)
    End If
    
    For Each fldFolder In PFolder.Folders
        If LCase(fldFolder.Name) = LCase(thisLevel) Then
            If thisLevel = ssPath Then
                Set getFolder = fldFolder
                Exit Function
            Else
                Set getFolder = getFolder(nextLevel, fldFolder)
                Exit Function
            End If
            DoEvents
        End If
    Next
End Function
 
Function PermanentlyDelete(ByVal sCategory As String) As Boolean
    On Error GoTo ErrorHandler
    Dim bRet As Boolean: bRet = True
    Dim nmsName As Outlook.NameSpace: Set nmsName = Application.GetNamespace("MAPI")
    Dim oFolder As Outlook.MAPIFolder: Set oFolder = nmsName.GetDefaultFolder(olFolderDeletedItems)
    Dim oMail As Outlook.MailItem
    
    ' TODO: Attempt to only get emails for the specified category so we don't loop the entire deleted folder each time
    For Each oMail In oFolder.Items
        If oMail.Categories = sCategory Then
            oMail.Delete
            DoEvents
        End If
        DoEvents
    Next
    
    PermanentlyDelete = bRet
    Set oMail = Nothing
    Set oFolder = Nothing
    Set nmsName = Nothing
Exit Function
ErrorHandler:
    If Err.Number <> 0 Then
        bRet = False
        MsgBox ("Error No: " & Err.Number & vbNewLine & "Error Desc: " & Err.Description)
        PermanentlyDelete = bRet
    End If
End Function

Any help would be appreciated

Cheers Al

[aconybeare]

I think I've solved this although I may not be the best solution.

I'm using find to search for the marked up emails in the PermanentlyDelete Function

Option Explicit
 
' To use the Alerts and helpdesk functions you must create two categories
' NetworkAlert and HelpDesk. These are used to mark the messages, so we can just delete
' the specific messages.
' Resources:
' [url]http://weblogs.asp.net/whaggard/archive/2004/11/12/256661.aspx[/url]
' [url]http://www.outlookcode.com/[/url]
 
Sub Alerts()
    Dim nmsName As Outlook.NameSpace: Set nmsName = Application.GetNamespace("MAPI")
    Dim fldPFolder As Outlook.MAPIFolder: Set fldPFolder = nmsName.GetDefaultFolder(olFolderInbox).Parent
    Dim sTPath As String: sTPath = "Alerts"
    Dim oFolder As Outlook.MAPIFolder: Set oFolder = getFolder(sTPath, fldPFolder)
    Dim oMail As Outlook.MailItem
    Dim bDoPermDel As Boolean: bDoPermDel = False
    Dim sCat As String: sCat = "NetworkAlert"
        
    Do While oFolder.Items.Count > 0
        DoEvents
        Set oMail = oFolder.Items(1)
        DoEvents
        With oMail
            .UnRead = False
            .Categories = sCat
            .Save
            .Delete
        End With
        Set oMail = Nothing
        DoEvents
        bDoPermDel = True
    Loop
 
 
    If bDoPermDel = True Then Call PermanentlyDelete(sCat)
            
    Set oFolder = Nothing
    Set fldPFolder = Nothing
    Set nmsName = Nothing
End Sub
 
Function getFolder(ByVal ssPath As String, PFolder As MAPIFolder) As MAPIFolder
    Dim fldFolder As Outlook.MAPIFolder
    Dim thisLevel
    Dim nextLevel
    Dim t As Integer: t = InStr(ssPath, "\")
    If t = 0 Then
        thisLevel = ssPath
    Else
        thisLevel = Left(ssPath, t - 1)
        nextLevel = Mid(ssPath, t + 1)
    End If
    
    For Each fldFolder In PFolder.Folders
        If LCase(fldFolder.Name) = LCase(thisLevel) Then
            If thisLevel = ssPath Then
                Set getFolder = fldFolder
                Exit Function
            Else
                Set getFolder = getFolder(nextLevel, fldFolder)
                Exit Function
            End If
            DoEvents
        End If
    Next
End Function
 
Function PermanentlyDelete(ByVal sCategory As String) As Boolean
    On Error GoTo ErrorHandler
    Dim bRet As Boolean: bRet = True
    Dim oNS As Outlook.NameSpace: Set oNS = Application.GetNamespace("MAPI")
    Dim oFolder As Outlook.MAPIFolder: Set oFolder = oNS.GetDefaultFolder(olFolderDeletedItems)
    Dim oItems As Outlook.Items: Set oItems = oFolder.Items
    Dim sSearch: sSearch = "[Categories] = " & Quote(sCategory)
    
    Set oFolder = Nothing
    Set oNS = Nothing
    ' New and improved: Only get msgs with the appropriate category
    Set oItems = oItems.Restrict(sSearch)
    DoEvents
    If oItems.Count > 0 Then
        Do While oItems.Count > 0
            DoEvents
            oItems.Remove (1)
            DoEvents
        Loop
    End If
    
    PermanentlyDelete = bRet
    Set oItems = Nothing
Exit Function
ErrorHandler:
    If Err.Number <> 0 Then
        Select Case Err.Number
            Case 13: Resume Next ' Type Mismatch
            Case Else
                bRet = False
                MsgBox ("Error No: " & Err.Number & vbNewLine & "Error Desc: " & Err.Description)
                PermanentlyDelete = bRet
        End Select
    End If
End Function
 
Function Quote(MyText)
    Quote = Chr(34) & MyText & Chr(34)
End Function