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