Outlook 2000 macro

  • Thread starter Thread starter Guest
  • Start date Start date
G

Guest

Please help me. I need a macro which will loop through all the emails in a
folder called "Database" under a group email inbox called "safety" and search
and delete the following text **Remove This Phrase** including the asterisks
from the Subject field.

Many thanks for any responses or advice.
 
Try this macro:

Sub ReplaceSubjectTextInFolderEmails()
On Error Resume Next

Dim objNS As Outlook.NameSpace
Dim objFolder As Outlook.MAPIFolder
Dim objItem As Object
Dim strFind As String
Dim objItems As Outlook.Items

Set objNS = Application.GetNamespace("MAPI")
Set objFolder = objNS.PickFolder

If objFolder Is Nothing Then Exit Sub

strFind = InputBox("Enter the Subject text that you want to find and
remove:")
Set objItems = objFolder.Items

For Each objItem In objItems
objItem.Subject = Replace(objItem.Subject, strFind, "", , ,
vbTextCompare)
objItem.Save
Next

MsgBox "Finished.", vbOKOnly + vbInformation

Set objNS = Nothing
Set objFolder = Nothing
Set objItem = Nothing
Set objItems = Nothing
End Sub
 
Eric, thank you so much that is brilliant and it works wonderfully.

I will be even more grateful if you can show me how to reference the mailbox
and folder rather than using the PickFolder part of the script. The reason
is the macro will only ever need to look at one designated folder. It's is a
group mailbox on Exchange if that helps at all.

Thank you once again, I have been looking for a solution to this for some
time.
 
No problem Richard. Glad to help.

When you say "group email inbox", is this a delegated e-mail folder or a
secondary mailbox? That makes a difference in how you access the folder.
I'll assume no...

Otherwise:

Sub ReplaceSubjectTextInFolderEmails()
On Error Resume Next

Dim objNS As Outlook.NameSpace
Dim objFolder As Outlook.MAPIFolder
Dim objItem As Object
Dim strFind As String
Dim objItems As Outlook.Items

Set objNS = Application.GetNamespace("MAPI")
Set objFolder = objNS.GetDefaultFolder(olFolderInbox)
Set objFolder = objFolder.Folders.Item("Test")

If objFolder Is Nothing Then Exit Sub

strFind = InputBox("Enter the Subject text that you want to find and
remove:")
Set objItems = objFolder.Items

For Each objItem In objItems
objItem.Subject = Replace(objItem.Subject, strFind, "", , ,
vbTextCompare)
objItem.Save
Next

MsgBox "Finished.", vbOKOnly + vbInformation

Set objNS = Nothing
Set objFolder = Nothing
Set objItem = Nothing
Set objItems = Nothing
End Sub

--
Eric Legault (Outlook MVP, MCDBA, old school WOSA MCSD, B.A.)
Try Picture Attachments Wizard for Outlook:
http://www.collaborativeinnovations.ca
Blog: http://blogs.officezealot.com/legault/
 
Back
Top