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之前 - 网址
VOP08011316314153US/ - 产品ID变量（有数千个）
enter.asp?z=AFE38DC1F69084D0B95648B21B8F1DC65E2D7E9A11A710590C60AA49390E2DC928 - 每个客户唯一的访问密钥（我不使用它）

我想要一个脚本：

在Outlook收件箱文件夹

PRODUCT_ID_VARIABLE

创建根据PRODUCT_ID_VARIABLE命名的子文件夹（如果它不存在）
将具有不同PRODUCT_ID_VARIABLE的邮件移动到相应的子文件夹中。

在下面的示例中，脚本应创建文件夹VOP08011316314153US和VOP08011316314154US（如果它们尚不存在），并移动所有包含产品ID VOP08011316314153US和{{1}的邮件在URL中：

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

VOP08011316314154US

我是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>


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

Answer 1

宏将在INBOX中运行所有邮件..这可能需要一些时间

' 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 item create mail folder,move mail item

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

1 个答案: