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

在我之前的question上看起来我误解了你，

也许这就是您尝试做的事情，以下代码将所有Items主题行保存/添加到集合中，然后继续搜索多个文件夹，然后删除它是否找到重复项 -

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

注意：避免隐藏其他对象的变量名（例如Dim Items As Items）

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

2 个答案: