VBA - Outlook 2010 - 在 URL 中搜索变量并将邮件移动到相应的文件夹

Question

在 Outlook 2010 中，我为多个客户提供了数千个电子邮件产品更新，其中 URL 位于 像这样的消息正文：

http://shop.khlynov.net/products/en/PRODUCT_ID_VARIABLE/enter.asp?z=UNIQUE_ACCESS_KEY

类似的东西：

http://shop.khlynov.net/products/en/VOP08011316314153US/enter.asp?z=AFE38DC1F69084D0B95648B21B8F1DC65E2D7E9A11A710590C60AA49390E2DC928

地点：

• VOP08011316314153US 之前的所有内容 - URL 的常量部分
• VOP08011316314153US/ - 产品 ID 变量（有数千个）
• enter.asp?z=AFE38DC1F69084D0B95648B21B8F1DC65E2D7E9A11A710590C60AA49390E2DC928 - 每个客户唯一的访问密钥（我不使用它）

我想要一个脚本：

1. 在 Outlook 收件箱文件夹的所有邮件中搜索 PRODUCT_ID_VARIABLE
2. 创建以PRODUCT_ID_VARIABLE命名的子文件夹（如果不存在）
3. 将具有不同 PRODUCT_ID_VARIABLE 的消息移动到相应的子文件夹中。

在下面的示例中，脚本应创建文件夹 VOP08011316314153US 和 VOP08011316314154US（如果它们不存在）并将 URL 中产品 ID 为 VOP08011316314153US 和 VOP08011316314154US 的所有消息移到那里：

以下是电子邮件正文的示例：

<table align="left">
    <tr>
        <td style="padding: 9px;" align="left">
            <p style="font-size: 10px; font-family: 'Trebuchet MS', Arial, Helvetica, sans-serif;
                            color: #333333;">
               <span style="color: #9B0124;">PRODUCT LINK: </span><br />
                  <a href="http://shop.khlynov.net/products/en/VOP23011304005259US/enter.asp?z=ABCC226C7CBA08F2D0CE2BAB7CBFE493E04D9533489C3FF245EB4061D0FA6A7D18" target="_blank" style="text-decoration: none; color: #333333;">http:/<wbr>/<wbr>shop.khlynov.net/<wbr>products/<wbr>en/<wbr>VOP23011304005259US/<wbr>enter.asp?z=ABCC226C7CBA08F2D0CE2BAB7CBFE493E04D9533489C3FF245EB4061D0FA6A7D18</a>
           </p>
       </td>
   </tr>
</table>


INBOX
-VOP08011316314153US
-- Email 1
-- Email 2
-- Email ...
-- Email X
-VOP08011316314154US
-- Email 1
-- Email 2
-- Email ...
-- Email X

我是 VBA 编码的新手。有人可以帮忙从头开始编写代码吗？

---

我刚刚发现您的宏适用于纯文本，但不适用于 HTML 字母。这是HTML代码的一部分：

<table align="left">
                <tr>
                    <td style="padding: 9px;" align="left">
                        <p style="font-size: 10px; font-family: 'Trebuchet MS', Arial, Helvetica, sans-serif;
                            color: #333333;">
                            <span style="color: #9B0124;">PRODUCT LINK: </span>
                            <br />
                            <a href="http://shop.khlynov.net/products/en/VOP23011304005259US/enter.asp?z=ABCC226C7CBA08F2D0CE2BAB7CBFE493E04D9533489C3FF245EB4061D0FA6A7D18" target="_blank" style="text-decoration: none; color: #333333;">http:/<wbr>/<wbr>shop.khlynov.net/<wbr>products/<wbr>en/<wbr>VOP23011304005259US/<wbr>enter.asp?z=ABCC226C7CBA08F2D0CE2BAB7CBFE493E04D9533489C3FF245EB4061D0FA6A7D18</a>
                        </p>
                    </td>
                </tr>
            </table>

Answer 1

宏将为收件箱中的所有邮件运行.. 可能需要一些时间

' run this macro
Sub main_procedure()
    On Error GoTo eh:
    Dim ns As Outlook.NameSpace
    Dim folder As MAPIFolder
    Dim item As Object
    Dim msg As MailItem

    Set ns = Session.Application.GetNamespace("MAPI")
    Set folder = ns.GetDefaultFolder(olFolderInbox)
    MsgBox "Total Number of mail in your inbox " & folder.Items.Count
    For Each item In folder.Items

        If (item.Class = olMail) Then
            Set msg = item
            If InStr(msg.Body, "http://shop.khlynov.net/products/en/") > 0 Then
                URL = msg.Body
                createAndMoveMail URL, msg

            ElseIf InStr(msg.Subject, "http://shop.khlynov.net/products/en/") > 0 Then
                URL = msg.Subject
                createAndMoveMail URL, msg
            End If
        End If
    Next


    Exit Sub
eh:
    MsgBox Err.Description, vbCritical, Err.Number
End Sub



Sub createAndMoveMail(ByVal URL As String, ByRef mail As MailItem)
Dim productID As String
Dim URLPath As String
Dim folderExist As Boolean
Dim startIndex As Long
Dim found As Boolean
On Error goto 0
found = False

Do While Not found
    productID = ""
    startIndex = InStr(URL, "http://shop.khlynov.net/products/en/")
    If startIndex = 0 Then
        Exit Sub
    End If
    URLPath = Mid(URL, startIndex)
    URLPath = Mid(URLPath, Len("http://shop.khlynov.net/products/en/") + 1)
    'update new url
    URL = URLPath
    If InStr(ULRPath, "/") = 0 Then
        Exit Sub
    End If
    productID = Mid(URLPath, 1, InStr(URLPath, "/") - 1)
    If Len(productID) = 19 And InStr(productID, "VOP") > 0 And InStr(productID, "US") > 0 Then
        found = True
        Exit Do
    End If
Loop



If Not found Then
    Exit Sub
End If





Dim myInbox As Outlook.MAPIFolder
Set myInbox = Outlook.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)

folderExist = False
For i = 1 To myInbox.Folders.Count
    If myInbox.Folders.item(i).Name = productID Then
        folderExist = True
        Set myDestinationFolder = myInbox.Folders.item(i)
        Exit For
    End If
Next
If Not folderExist Then
    Set myDestinationFolder = myInbox.Folders.Add(productID, olFolderInbox)
End If

mail.Move myDestinationFolder
End Sub

参考：read inbox mail itemcreate mail folder,move mail item