OL2003: Get Mail items from Folder
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?
vb Code:
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
Re: OL2003: Get Mail items from Folder
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
vb Code:
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