Script to delete duplcate messages in Outlook 2003

  • Thread starter Thread starter David Sherman
  • Start date Start date
D

David Sherman

Has anyone seen a VBS script that will remove duplicate messsages in
an Outllo 2003 *.pst file.

thanks
 
When I copy the code in Outlook, I get an Compile error- unexpected
end sub.

How do I fix this?

thanks

Sub NoMore()
' Code sample by Ulfar Erlingsson [[email protected]]
' Moves duplicate items from the Inbox to a Dupes folder
' created under the Inbox

Private Sub MoveDuplicates()
Dim myDate As Date
Dim dupDate As Date
Dim mySubject As String
Dim dupSubject As String
Dim mySender As String
Dim dupSender As String
Dim myItems As Items
Dim myInbox As MAPIFolder
Dim myItem As Object
Dim dupItem As Object

Set myOlApp = CreateObject("Outlook.Application")
Set myNameSpace = myOlApp.GetNamespace("MAPI")
Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox)
Set myItems = myInbox.Items
On Error Resume Next
Set dupsFolder = myInbox.Folders("Dupes")
If Err <> 0 Then
Set dupsFolder = myInbox.Folders.Add("Dupes")
Err.Clear
End If

myItems.Sort "[Subject]", False
Set myItem = myItems.GetFirst
While TypeName(myItem) <> "Nothing"
If TypeName(myItem) = "MailItem" Then
myDate = myItem.ReceivedTime
mySubject = myItem.Subject
mySender = myItem.SenderName
If Err = 0 Then
Set dupItem = myItems.GetNext
dupDate = dupItem.CreationTime
If TypeName(dupItem) = "MailItem" Then
dupSubject = dupItem.Subject
dupSender = dupItem.SenderName
End If
If TypeName(dupItem) = "MailItem" _
And mySubject = dupItem.Subject _
And mySender = dupItem.SenderName _
And DateDiff("n", myDate, dupDate) < 2 Then
dupItem.Move dupsFolder
Else
Set myItem = dupItem
End If
Else
Err.Clear
Set myItem = myItems.GetNext
End If
End If
Wend

Set myItem = Nothing
Set dupItem = Nothing
Set myItems = Nothing
Set myInbox = Nothing
Set myNameSpace = Nothing
Set myOlApp = Nothing
End Sub

End Sub
 
Take out the Sub NoMore declaration and extra End Sub statement. You can't declare one sub inside another.

--
Sue Mosher, Outlook MVP
Author of Configuring Microsoft Outlook 2003

and Microsoft Outlook Programming - Jumpstart for
Administrators, Power Users, and Developers



David Sherman said:
When I copy the code in Outlook, I get an Compile error- unexpected
end sub.

How do I fix this?

thanks

Sub NoMore()
' Code sample by Ulfar Erlingsson [[email protected]]
' Moves duplicate items from the Inbox to a Dupes folder
' created under the Inbox

Private Sub MoveDuplicates()
Dim myDate As Date
Dim dupDate As Date
Dim mySubject As String
Dim dupSubject As String
Dim mySender As String
Dim dupSender As String
Dim myItems As Items
Dim myInbox As MAPIFolder
Dim myItem As Object
Dim dupItem As Object

Set myOlApp = CreateObject("Outlook.Application")
Set myNameSpace = myOlApp.GetNamespace("MAPI")
Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox)
Set myItems = myInbox.Items
On Error Resume Next
Set dupsFolder = myInbox.Folders("Dupes")
If Err <> 0 Then
Set dupsFolder = myInbox.Folders.Add("Dupes")
Err.Clear
End If

myItems.Sort "[Subject]", False
Set myItem = myItems.GetFirst
While TypeName(myItem) <> "Nothing"
If TypeName(myItem) = "MailItem" Then
myDate = myItem.ReceivedTime
mySubject = myItem.Subject
mySender = myItem.SenderName
If Err = 0 Then
Set dupItem = myItems.GetNext
dupDate = dupItem.CreationTime
If TypeName(dupItem) = "MailItem" Then
dupSubject = dupItem.Subject
dupSender = dupItem.SenderName
End If
If TypeName(dupItem) = "MailItem" _
And mySubject = dupItem.Subject _
And mySender = dupItem.SenderName _
And DateDiff("n", myDate, dupDate) < 2 Then
dupItem.Move dupsFolder
Else
Set myItem = dupItem
End If
Else
Err.Clear
Set myItem = myItems.GetNext
End If
End If
Wend

Set myItem = Nothing
Set dupItem = Nothing
Set myItems = Nothing
Set myInbox = Nothing
Set myNameSpace = Nothing
Set myOlApp = Nothing
End Sub

End Sub



Am Mon, 20 Feb 2006 13:56:39 -0500 schrieb David Sherman:

No VBS, but VBA. Maybe you can use it as a template for your own VBScript:
http://www.outlookcode.com/d/code/movemaildupes.htm
Click to expand...
Click to expand...
 
Am Tue, 21 Feb 2006 11:59:12 -0500 schrieb David Sherman:

Please delete the outer Sub/End Sub.

--
Viele Gruesse / Best regards
Michael Bauer - MVP Outlook
-- www.vbOffice.net --

When I copy the code in Outlook, I get an Compile error- unexpected
end sub.

How do I fix this?

thanks

Sub NoMore()
' Code sample by Ulfar Erlingsson [[email protected]]
' Moves duplicate items from the Inbox to a Dupes folder
' created under the Inbox

Private Sub MoveDuplicates()
Dim myDate As Date
Dim dupDate As Date
Dim mySubject As String
Dim dupSubject As String
Dim mySender As String
Dim dupSender As String
Dim myItems As Items
Dim myInbox As MAPIFolder
Dim myItem As Object
Dim dupItem As Object

Set myOlApp = CreateObject("Outlook.Application")
Set myNameSpace = myOlApp.GetNamespace("MAPI")
Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox)
Set myItems = myInbox.Items
On Error Resume Next
Set dupsFolder = myInbox.Folders("Dupes")
If Err <> 0 Then
Set dupsFolder = myInbox.Folders.Add("Dupes")
Err.Clear
End If

myItems.Sort "[Subject]", False
Set myItem = myItems.GetFirst
While TypeName(myItem) <> "Nothing"
If TypeName(myItem) = "MailItem" Then
myDate = myItem.ReceivedTime
mySubject = myItem.Subject
mySender = myItem.SenderName
If Err = 0 Then
Set dupItem = myItems.GetNext
dupDate = dupItem.CreationTime
If TypeName(dupItem) = "MailItem" Then
dupSubject = dupItem.Subject
dupSender = dupItem.SenderName
End If
If TypeName(dupItem) = "MailItem" _
And mySubject = dupItem.Subject _
And mySender = dupItem.SenderName _
And DateDiff("n", myDate, dupDate) < 2 Then
dupItem.Move dupsFolder
Else
Set myItem = dupItem
End If
Else
Err.Clear
Set myItem = myItems.GetNext
End If
End If
Wend

Set myItem = Nothing
Set dupItem = Nothing
Set myItems = Nothing
Set myInbox = Nothing
Set myNameSpace = Nothing
Set myOlApp = Nothing
End Sub

End Sub



Am Mon, 20 Feb 2006 13:56:39 -0500 schrieb David Sherman:

No VBS, but VBA. Maybe you can use it as a template for your own VBScript:
http://www.outlookcode.com/d/code/movemaildupes.htm
Click to expand...
Click to expand...
 
When I delete the following:

Sub NoMore()
' Code sample by Ulfar Erlingsson [[email protected]]
' Moves duplicate items from the Inbox to a Dupes folder
' created under the Inbox

and the
End Sub, the macro doesn't show up.

When I deleted the word "private", the macro appears to run properly.

Thanks for the help.

Am Tue, 21 Feb 2006 11:59:12 -0500 schrieb David Sherman:

Please delete the outer Sub/End Sub.

--
Viele Gruesse / Best regards
Michael Bauer - MVP Outlook
-- www.vbOffice.net --

When I copy the code in Outlook, I get an Compile error- unexpected
end sub.

How do I fix this?

thanks

Sub NoMore()
' Code sample by Ulfar Erlingsson [[email protected]]
' Moves duplicate items from the Inbox to a Dupes folder
' created under the Inbox

Private Sub MoveDuplicates()
Dim myDate As Date
Dim dupDate As Date
Dim mySubject As String
Dim dupSubject As String
Dim mySender As String
Dim dupSender As String
Dim myItems As Items
Dim myInbox As MAPIFolder
Dim myItem As Object
Dim dupItem As Object

Set myOlApp = CreateObject("Outlook.Application")
Set myNameSpace = myOlApp.GetNamespace("MAPI")
Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox)
Set myItems = myInbox.Items
On Error Resume Next
Set dupsFolder = myInbox.Folders("Dupes")
If Err <> 0 Then
Set dupsFolder = myInbox.Folders.Add("Dupes")
Err.Clear
End If

myItems.Sort "[Subject]", False
Set myItem = myItems.GetFirst
While TypeName(myItem) <> "Nothing"
If TypeName(myItem) = "MailItem" Then
myDate = myItem.ReceivedTime
mySubject = myItem.Subject
mySender = myItem.SenderName
If Err = 0 Then
Set dupItem = myItems.GetNext
dupDate = dupItem.CreationTime
If TypeName(dupItem) = "MailItem" Then
dupSubject = dupItem.Subject
dupSender = dupItem.SenderName
End If
If TypeName(dupItem) = "MailItem" _
And mySubject = dupItem.Subject _
And mySender = dupItem.SenderName _
And DateDiff("n", myDate, dupDate) < 2 Then
dupItem.Move dupsFolder
Else
Set myItem = dupItem
End If
Else
Err.Clear
Set myItem = myItems.GetNext
End If
End If
Wend

Set myItem = Nothing
Set dupItem = Nothing
Set myItems = Nothing
Set myInbox = Nothing
Set myNameSpace = Nothing
Set myOlApp = Nothing
End Sub

End Sub



Am Mon, 20 Feb 2006 13:56:39 -0500 schrieb David Sherman:

No VBS, but VBA. Maybe you can use it as a template for your own VBScript:
http://www.outlookcode.com/d/code/movemaildupes.htm

--
Viele Gruesse / Best regards
Michael Bauer - MVP Outlook
-- www.vbOffice.net --


Has anyone seen a VBS script that will remove duplicate messsages in
an Outllo 2003 *.pst file.

thanks
Click to expand...
Click to expand...
Click to expand...
 
One Additional question:

When I run the script, I get a dialog box that says:

A program is trying to access e-mail addresses you have store in
Outlook. Do you want to allow this?

If I say yes, I get a time lime of up to 10 minutes.

How to I increase that time?

If I use 10 minutes, only 256 duplicates are found. I know that I have
over 8000 duplicate messages.

thanks
 
YOu can't increase the time. See http://www.outlookcode.com/d/sec.htm for your options with regard to the "object model guard" security in Outlook 2000 SP2 and later versions.

--
Sue Mosher, Outlook MVP
Author of Configuring Microsoft Outlook 2003

and Microsoft Outlook Programming - Jumpstart for
Administrators, Power Users, and Developers
 
Thanks for the information.

YOu can't increase the time. See http://www.outlookcode.com/d/sec.htm for your options with regard to the "object model guard" security in Outlook 2000 SP2 and later versions.

--
Sue Mosher, Outlook MVP
Author of Configuring Microsoft Outlook 2003

and Microsoft Outlook Programming - Jumpstart for
Administrators, Power Users, and Developers
Click to expand...
 
Am Tue, 21 Feb 2006 13:49:16 -0500 schrieb David Sherman:

That´s the way it goes: Via Tools/Macro/Macros... only those are visible
which are declared as Public and don´t use any parameter.
 
Back
Top