Moźesz sie zaintersowac programowaniem w stylu http://www.slipstick.com/ , http://www.lbetoolbox.com/ , http://www.sperrysoftware.com/Outlook/default.asp

W necie jeszcze takie makro znalazłem:

–––––––––––––––––––––––––––––––––––––––––––––––––––––––––––––––––––––––––––
Sub remove_sub_emails()
On Error Resume Next
Dim MyFolder, Item, totaal, check, BinnenCounter, BuitenCounter,
NixGevonden, vraag, verwijderteller, i, gevonden, invoerwaarde,
mailtjesverzondenop(900), mailtjessubject(900), verwijderen(900)
'invoerwaarde = InputBox("Enter the name of the folder to check for
duplicate folders..")
invoerwaarde = Application.ActiveExplorer.CurrentFolder


Dim invoerwaardevar As String


' It's best if you change your folder (that is in the outlook window)
Personal Folders to PersonalFolders..
invoerwaardevar = "PersonalFolders/" & invoerwaarde
Set MyFolder = GetFolder(invoerwaardevar)
Set Item = MyFolder.Items
check = True: BinnenCounter = 1: BuitenCounter = 1: NixGevonden = True:
verwijderteller = 1: i = 1


'using an array is way faster
Do While BinnenCounter
mailtjesverzondenop(BinnenCounter) =
Item(BinnenCounter).SentOn ' Array laden
mailtjessubject(BinnenCounter) =
Item(BinnenCounter).Subject
BinnenCounter = BinnenCounter + 1
Loop


BuitenCounter = 1: BinnenCounter = 1 ' Resetten
totaal = Item.Count


Do
Do While BinnenCounter
If mailtjessubject(BuitenCounter) =
mailtjessubject(BinnenCounter) And BuitenCounter <> BinnenCounter Then
If
mailtjesverzondenop(BinnenCounter) = mailtjesverzondenop(BuitenCounter) Then
'And Item(BinnenCounter).SentOn = Item(BuitenCounter).SentOn Then


gevonden
= False
For i =
1 To totaal


If verwijderen(i) = BinnenCounter Then


gevonden = True


Exit For


End If
Next
If
gevonden = False Then


verwijderen(verwijderteller) = BinnenCounter


verwijderteller = verwijderteller + 1
'
Item(BinnenCounter).Display
End If
End If


End If
BinnenCounter = BinnenCounter + 1
Loop
BuitenCounter = BuitenCounter + 1
BinnenCounter = BuitenCounter + 1
If BuitenCounter = Item.Count Then
check = False
End If
Loop Until check = False
Dim verwijdertellervar
verwijdertellervar = verwijderteller – 1
For i = 1 To verwijdertellervar
Item(verwijderen(i)).Delete
Next


Set MyFolder = Nothing
Set Item = Nothing
Set totaal = Nothing
Set check = Nothing
Set BinnenCounter = Nothing
Set BuitenCounter = Nothing
Set NixGevonden = Nothing
Set vraag = Nothing
Set verwijderteller = Nothing
Set i = Nothing
Set gevonden = Nothing
Set invoerwaarde = Nothing
Set verwijdertellervar = Nothing


End Sub


Public Function GetFolder(strFolderPath As String) As MAPIFolder


' folder path needs to be something like
' "Public Folders/All Public Folders/Company/Sales"


Dim objApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim colFolders As Outlook.Folders
Dim objFolder As Outlook.MAPIFolder
Dim arrFolders() As String
Dim i As Long
On Error Resume Next


strFolderPath = Replace(strFolderPath, "/", "\")
arrFolders() = Split(strFolderPath, "\")
Set objNS = Application.GetNamespace("MAPI")
Set objFolder = objNS.Folders.Item(arrFolders(0))


If Not objFolder Is Nothing Then
For i = 1 To UBound(arrFolders)
Set colFolders = objFolder.Folders
Set objFolder = Nothing
Set objFolder = colFolders.Item(arrFolders(i))
If objFolder Is Nothing Then
Exit For
End If
Next
End If


Set GetFolder = objFolder
Set colFolders = Nothing
Set objNS = Nothing
Set objApp = Nothing


End Function
–––––––––––––––––––––––––––––––––