Question

我们的防火墙用户发送消息，要求取消阻止他们认为不应阻止的某些网站。他们的邮件主题字段包含此类网站网址。实际上，每条消息都会发送一个网址。由于用户数量的增加，预计每天会收到数百条或几千条消息。

是否有一个Outlook宏将收集或提取此类网址（从收到的邮件主题字段）到一个文本文件而不必打开任何邮件？

深切感谢对此事的任何帮助。

提前致谢

Answer 1

请将此代码写入Outlook VBA模块。在下面的某些行中更改文件夹和目标文件的某些名称。有关其他信息，请参阅子内的注释。

Sub Retrieve_http()

'our Outlook folder- deifinitions
    Dim myItem As MailItem
    Dim myFolder As Folder
    Dim myNamespace As NameSpace
    Set myNamespace = Application.GetNamespace("MAPI")
    'put your folders name here
    '1st one is store folder which should refer to firewall_support@iuass.org
    'second is possibly 'inbox folder'
    Set myFolder = myNamespace.folders("firewall_support@iuass.org").folders("inbox")

'destination file
    Dim resFile As String
        resFile = "c:\Users\Kazik\Desktop\httpRequest.txt"
    Dim ff As Byte
        ff = FreeFile()
    'creating or opening it- each time you run this macro we will append data
    'until deletion of either file or its content
    Open resFile For Append As #ff

    For Each myItem In myFolder.items
        If InStr(1, myItem.Subject, "http://") > 0 And _
            InStr(1, myItem.Subject, "classified under:") > 0 Then
                'write to file
                Write #ff, myItem.Subject

        End If
    Next
    Close #ff
End Sub

编辑以包含适当的删除过程并将代码引用到图片中。

以下图片显示Outlook窗口（波兰语版）其中：Business Mail是Top Folders之一（指的是单独的.pst文件）。 'Skrzynka odbiorcza'就是'收件箱'。

enter image description here

搜索某些电子邮件，检索电子邮件主题和删除电子邮件的代码如下所示：

Sub Retrieve_http()

'our Outlook folder- deifinitions
    Dim myItem As MailItem
    Dim myFolder As Folder
    Dim myNamespace As NameSpace
    Set myNamespace = Application.GetNamespace("MAPI")
    'put your folders name here
    Set myFolder = myNamespace.folders("Business Mail").folders("skrzynka odbiorcza")

'destination file
    Dim resFile As String
        resFile = "c:\Users\Kazik\Desktop\httpRequest.txt"
    Dim ff As Byte
        ff = FreeFile()
    'creating or opening it- each time you run this macro we will append data
    'until deletion of either file or its content
    Open resFile For Append As #ff
    Dim i!
    For i = myFolder.items.Count To 1 Step -1
        If InStr(1, myFolder.items(i).Subject, "http://") > 0 And _
            InStr(1, myFolder.items(i).Subject, "classified under") > 0 Then
                'write to file
                Write #ff, myFolder.items(i).Subject
                'delete item
                myFolder.items(i).Delete
        End If
    Next
    Close #ff
End Sub

Answer 2

这是你问题的解决方案:)

制作For Each Outlook时，它会枚举每封电子邮件。如果您在循环For Each中移动任何电子邮件，则Outlook会更改该文件夹的所有电子邮件的数量，但不会更改循环的迭代次数。这会导致几条消息无法读取。

解决方案是从上一封电子邮件开始循环，如此处所述 Outlook macro to collect/extract data from "Subject field" of numerous messages into a text file

CODE：使用

替换（对于Inbox.Items中的每个InboxMsg）

对于i = Inbox.Items.Count到1步-1'从末尾向后迭代设置InboxMsg = Inbox.Items（i）

Outlook宏用于从众多消息的“主题字段”中收集/提取数据到文本文件中

2 个答案: