VBA - Outlook 2010 - Search variable in URLs and move messages to the corresponding folders

Question

In Outlook 2010 I have thousand email products updates for multiple customers with URL in message body like that:

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

something like that:

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

where:

• all before VOP08011316314153US - constant part of URL
• VOP08011316314153US/ - product ID variable (there are thousands)
• enter.asp?z=AFE38DC1F69084D0B95648B21B8F1DC65E2D7E9A11A710590C60AA49390E2DC928 - access key unique for each customer (I don't use it)

I want that a script:

1. search for PRODUCT_ID_VARIABLE in all messages in Outlook Inbox folder
2. create subfolders named according to the PRODUCT_ID_VARIABLE (if it doesn't exist)
3. move messages with different PRODUCT_ID_VARIABLE into corresponding subfolders.

In the example below a script should create folders VOP08011316314153US and VOP08011316314154US (if they don't already exist) and move there all messages with product IDs VOP08011316314153US and VOP08011316314154US in URLs:

Here's an example of how the email body may look like:

<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

I am very new in VBA coding. Could anyone help to write a code from a scratch?

---

I've just found that your macro work well with plain text but doesn't work with HTML letters. Here's the part of HTML code:

<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

The macro will run for ALL mail in INBOX .. it may takes some time

' 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

Reference: read inbox mail item create mail folder,move mail item