Private Type BROWSEINFO
  hOwner As Long
  pidlRoot As Long
  pszDisplayName As String
  lpszTitle As String
  ulFlags As Long
  lpfn As Long
  lParam As Long
  iImage As Long
End Type
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias _
            "SHGetPathFromIDListA" (ByVal pidl As Long, _
            ByVal pszPath As String) As Long
            
Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias _
            "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) _
            As Long
            
Private Const BIF_RETURNONLYFSDIRS = &H1
Const MailFieldToSort = "Received"                '"Received"      for english Version
Const MailErasedFolder = "Deleted Items" '"Deleted Items" for english Version
Dim lCount As Long 'to count the deleted items

Public Function BrowseFolder(szDialogTitle As String) As String
  Dim x As Long, bi As BROWSEINFO, dwIList As Long
  Dim szPath As String, wPos As Integer
  
    With bi
        .hOwner = hWndAccessApp
        .lpszTitle = szDialogTitle
        .ulFlags = BIF_RETURNONLYFSDIRS
    End With
    
    dwIList = SHBrowseForFolder(bi)
    szPath = Space$(512)
    x = SHGetPathFromIDList(ByVal dwIList, ByVal szPath)
    
    If x Then
        wPos = InStr(szPath, Chr(0))
        BrowseFolder = Left$(szPath, wPos - 1)
    Else
        BrowseFolder = vbNullString
    End If
End Function
'-----------------------------------------------------------------------
'  Macro « EmailsDeleteDouble » for Microsoft Outlook
'
'  Author            : J.-C. Stritt
'  Last update       : 01-NOV-2002
'  First release     : 31-OCT-2002
'  Environment       : VBA for Outlook 2002 (Office XP)
'  Operating system  : Windows XP
'
'  Goal              : delete emails in double in Outlook folders
'
'  Remarks           : - copy this code in a VBA module in Outlook
'                        (ALT-F11 to call VBA editor) and then run
'                        the macro
'                      - first based on Microsoft Q294457 - OL2002
'                        "How to Programmatically Search a Folder Tree"
'                      - delete double emails algorithm is based
'                        on a sort in a folder collection items
'                        and a compare key builded with email :
'                        SenderName + Subject + ReceivedTime
'                      - the macro give you the possibility to pickup
'                        an entry Folder. Then, the macro process
'                        each entry (delete if match) in the folder
'                        and recursivly to all subfolders
'
'  (C) Copyright 2002 by Jean-Claude Stritt (jcsinfo@bluewin.ch)
'  Note : you can copy this code freely, but please keep these comments
'-----------------------------------------------------------------------
'Option Explicit

'change these constants because the are Outlook language dependant


'add blanks at the ending of a string
Function AddBlanks(ByVal S As String, ByVal L As Integer) As String
  Dim i As Integer, Diff As Integer
  S = LTrim(S)
  Diff = L - Len(S)
  If Diff > 0 Then
    For i = 1 To Diff
      S = S + " "
    Next
  ElseIf Diff < 0 Then
    S = Left(S, L)
  End If
  AddBlanks = S
End Function


'the macro that delete the double in emails folders
Sub EmailsDeleteDouble()
  Dim olApp As Outlook.Application
  Dim olSession As Outlook.NameSpace
  Dim olStartFolder As Outlook.MAPIFolder
  Dim strPrompt As String

  'initialize some global var
  lCount = 0

  'get a reference to the Outlook application and session.
  Set olApp = Application
  Set olSession = olApp.GetNamespace("MAPI")

  'ok to begin process ?
  'If MsgBox("Ok to delete emails with double from a given pickup folder ?", vbYesNo + vbQuestion) = vbYes Then

    'allow the user to pick the folder in which to start the search.
    Set olStartFolder = olSession.PickFolder

    'check to make sure user didn't cancel PickFolder dialog.
    If Not (olStartFolder Is Nothing) Then

      'process the first folder (and other by recursive calls to ProcessFolder)
      'loop to catch all of them, until 0 messages are deleted
      Do
        Call ProcessFolder(olStartFolder)
        MsgBox CStr(lCount) & " messages were deleted.", vbInformation
      Loop Until CStr(lCount) = 0

    End If
  'End If
End Sub

'the process folder : each folder item is compared to the previous to delete double
Sub ProcessFolder(CurrentFolder As Outlook.MAPIFolder)
  Dim i As Long
  Dim strLastKey As String, strNewKey As String
  Dim olNewFolder As Outlook.MAPIFolder
  Dim olTempItem As Object     'could be various item types
  Dim myItems As Outlook.Items 'a local copy of the collection

  'initialize last key string
  strLastKey = ""

  'copy the collection (it's obligatory) and sort them
  Set myItems = CurrentFolder.Items
  Call myItems.Sort("[" & MailFieldToSort & "]", True)
  lCount = 0

  'loop through the items in the current folder (backwards in this case of items to delete)
  For i = myItems.Count To 1 Step -1

    Set olTempItem = myItems(i)
    
    'process only mail items [or meeting items
    If TypeName(olTempItem) = "MailItem" Or TypeName(olTempItem) = "MeetingItem" Then
      With olTempItem
        strNewKey = AddBlanks(.SenderName, 40) & AddBlanks(.Subject, 40) & .ReceivedTime

        'check to see if a match is found
        If strNewKey = strLastKey Then

          'if you want debug then uncomment next line
          'Debug.Print strNewKey

          'delete the item (comment the next line if you want just debug)
          If olTempItem.UnRead Then
            olTempItem.Delete
            'count deleted items
            lCount = lCount + 1
          ElseIf Not olTempItem.UnRead Then
            'if you've already read the message (and possibly already replied, delete the newer message)
            On Error Resume Next
            myItems(i + 1).Delete
            lCount = lCount + 1
           End If
        End If

        'memorize last key found
        strLastKey = strNewKey
      End With
    End If

  Next

  'loop through and search each subfolder of the current folder.
  For Each olNewFolder In CurrentFolder.Folders
    If olNewFolder.Name <> MailErasedFolder Then
      ProcessFolder olNewFolder
    End If
  Next

End Sub