如何比较所有RSS提要的所有标题并删除重复项？

Question

我想知道是否有方法比较ALL TITLES in ALL RSS FEEDS并删除重复项。

我读了很多RSS Feed，很明显，很多人都在多个论坛交叉发帖，然后我多次看到相同的RSS Feed。

我觉得剧本会是这个样子，但它似乎并没有删除受骗者.....

Option Explicit 
Public Sub DupeRSS() 
    Dim olNs As Outlook.NameSpace 
    Dim RSS_Folder As Outlook.MAPIFolder 

    Set olNs = Application.GetNamespace("MAPI") 
    Set RSS_Folder = olNs.GetDefaultFolder(olFolderRssFeeds) 

    'Process Current Folder 
    Example RSS_Folder 
End Sub 
Public Sub Example(ByVal ParentFolder As Outlook.MAPIFolder) 
    Dim itm As Object, itms As Items, dupes As Object, i As Long, k As Variant 

    Set dupes = CreateObject("Scripting.Dictionary") 
    Set itms = ParentFolder.Items 

    For i = itms.Folders.Count To 1 Step -1 
     Set itm = itms(i) 
     If TypeOf itm Is PostItem Then 
      If dupes.Exists(itm.Subject) Then itm.Delete Else dupes(itm.Subject) = 0 
     Else 
      Example itm  'Recursive call for Folders 
     End If 
    Next i 

    'Show dictionary items 
    If dupes.Count > 0 Then 
     For Each k In dupes 
      Debug.Print k 
     Next 
    End If 

    Set itm = Nothing: Set itms = Nothing: Set dupes = Nothing 
End Sub 

感谢所有！

Answer 1

看起来像我（前Dim Items As Items。）误解你对你以前question，

也许这就是你要做的，下面的代码保存/添加的所有项目主题行的集合，然后继续查找多个文件夹，然后如果发现duplicates-删除

Option Explicit 
Public Sub DupeRSS() 
    Dim olNs As Outlook.NameSpace 
    Dim RSS_Folder As Outlook.MAPIFolder 
    Dim DupItem As Object 

    Set DupItem = CreateObject("Scripting.Dictionary") 
    Set olNs = Application.GetNamespace("MAPI") 
    Set RSS_Folder = olNs.GetDefaultFolder(olFolderRssFeeds) 

' // Process Current Folder 
    Example RSS_Folder, DupItem 
End Sub 
Public Sub Example(ByVal ParentFolder As Outlook.MAPIFolder, _ 
        ByVal DupItem As Object) 
    Dim Folder As Outlook.MAPIFolder 
    Dim Item As Object 
    Dim Items As Items 
    Dim i As Long 

    Set Items = ParentFolder.Items 
    Debug.Print ParentFolder.Name 

    For i = Items.Count To 1 Step -1 
     DoEvents 

     If TypeOf Items(i) Is PostItem Then 
      Set Item = Items(i) 
      If DupItem.Exists(Item.Subject) Then 
       Debug.Print Item.Subject ' Print on Immediate Window 
       Debug.Print TypeName(Item) ' Print on Immediate Window 
       Item.Delete 
      Else 
       DupItem.Add Item.Subject, 0 
       Debug.Print DupItem.Count, Item.Subject 
      End If 
     End If 

    Next i 

' // Recurse through subfolders 
    If ParentFolder.Folders.Count > 0 Then 
     For Each Folder In ParentFolder.Folders 
      Example Folder, DupItem 
      Debug.Print Folder.Name 
     Next 
    End If 

    Set Folder = Nothing 
    Set Item = Nothing 
    Set Items = Nothing 
End Sub 

Answer 2

尝试改变波纹管

---

Option Explicit 

'Required - VBA Editor -> Tools -> References: Microsfot Outlook XXX Object Library 
'Required - VBA Editor -> Tools -> References: Microsfot Scripting Runtime (Dictionary) 

Public Sub RemoveRSSduplicates() 
    Dim olNs As Outlook.Namespace, olApp As Object, rssFolder As Folder, d As Dictionary 

    Set olApp = GetObject(, "Outlook.Application") 
    Set olNs = olApp.GetNamespace("MAPI") 
    Set rssFolder = olNs.GetDefaultFolder(olFolderRssFeeds) 
    Set d = CreateObject("Scripting.Dictionary") 

    ProcessOutlookRSSFeeds rssFolder, d 
End Sub 

---

Public Sub ProcessOutlookRSSFeeds(ByVal rssFolder As Folder, ByRef d As Dictionary) 
    Dim fldr As Folder, itm As Object 

    For Each fldr In rssFolder.Folders 
     If fldr.Items.Count > 0 Then 
      For Each itm In fldr.Items 
       If TypeOf itm Is PostItem Then 
        If Not d.Exists(itm.Subject) Then d(itm.Subject) = 0 Else itm.Delete 
       End If 
      Next 
     End If 
    Next 
End Sub 

---

注意：避免变量名，将隐藏其他对象