Migrating GMail to Exchange (part 3) - Conversion VBA Macro

Once you have configured your Outlook client, the next step is to add the conversion macro to Outlook.

1. Enter Macro editor

Press Alt+F11 to start the Macro editor in Outlook.  A security message may appear to indicate that you are enabling macros.

Select Enable Macros to proceed.

2. Open Outlook.VBA script:

In the Project tool-window, click on Project1 (VbaProject.OTM) => Microsoft Outlook Objects to access ThisOutlookSession.  Double click on ThisOutlookSession to open the script's edit window.

3. Paste macro

Copy and paste the following script into your global Outlook.VBA script (the edit window):

' Copyright 2012 Lajos Molnar except ToBase64String method, which is marked below.
' Licensed under the Creative Commons Attribution-ShareAlike 3.0 license
' See http://creativecommons.org/licenses/by-sa/3.0/

Option Explicit

Const IMAP = "you@domain.com"       ' name of outlook root folder where GMail account is read via IMAP
Const PST = "migrated"              ' name of outlook root folder where mail should be imported to
Const cache_folder = ""    ' name of subfolder inside PST where GMail folders are copied to (or empty)
Const trash_label = "T"    ' alternate name of Trash folder (or empty)

Const date_range = ""               ' date range to import (or empty)

#Const USE_BODY = 0                 ' set to 1 to use whole message body

' =============== HASHING ===============
Function ToBase64String(rabyt)
  'Ref: http://stackoverflow.com/questions/1118947/converting-binary-file-to-base64-string
  With CreateObject("MSXML2.DOMDocument")
    .LoadXML ""
    .DocumentElement.DataType = "bin.base64"
    .DocumentElement.nodeTypedValue = rabyt
    ToBase64String = Replace(.DocumentElement.text, vbLf, "")
  End With
End Function

Function getHash(ByRef sha1, ByRef strToHash As String) As String
    Dim inBytes() As Byte, shaBytes() As Byte, b, b2 As Byte
    Dim r As String
    inBytes() = strToHash
    shaBytes() = sha1.ComputeHash_2(inBytes)
    getHash = ToBase64String(shaBytes)
End Function

Function hashOf(ByRef sha1, i) As String
    Const PR_TRANSPORT_MESSAGE_HEADERS = "http://schemas.microsoft.com/mapi/proptag/0x007D001E"
    Dim olkPA As Outlook.PropertyAccessor
    Set olkPA = i.PropertyAccessor
    Dim body As String
    body = olkPA.GetProperty(PR_TRANSPORT_MESSAGE_HEADERS)
#If USE_BODY Then
    body = body + i.body
    If TypeName(i) = "MailItem" Then body = body + i.HTMLBody
#End If
    hashOf = getHash(sha1, body)
    Set olkPA = Nothing
End Function

Public Sub import_finally_all_mail()
    do_import True
End Sub

Public Sub import_all_labeled_messages()
    do_import False
End Sub

Private Sub do_import(final_import As Boolean)
    Dim dDone As New Scripting.Dictionary
    Dim dIMAP As New Scripting.Dictionary

    Dim sha1 As SHA1CryptoServiceProvider
    Debug.Print "Creating SHA1 service provider..."
    Set sha1 = New SHA1CryptoServiceProvider

    Dim MAPI As Outlook.NameSpace
    Set MAPI = ThisOutlookSession.GetNamespace("MAPI")

    Dim imap_folder As Outlook.MAPIFolder, target As Outlook.MAPIFolder, f As Variant
    Set imap_folder = MAPI.Folders(IMAP)
    Set target = MAPI.Folders(PST)

    Dim i As Variant, i2 As Variant
    Dim items As Outlook.items

    ' catalog imported messages
    Debug.Print "Cataloguing already imported messages... ";

    On Error Resume Next
    target.Folders.Add "Inbox"
    target.Folders.Add "Trash"
    On Error GoTo 0

    Dim target_list, c, cat As String
    target_list = Array(target, target.Folders("Inbox"), target.Folders("Trash"))

    For Each f In target_list
        Debug.Print "("; f.Name; ": "; f.items.Count; "messages) ";
        For Each i In f.items
            Dim h As String
            h = hashOf(sha1, i)

            If dDone.Exists(h) Then
                Debug.Print "***DUPLICATE***"; i.Parent.Name; ":"; i.Subject; "and"; dDone(h).Parent.Name; ":"; dDone(h).Subject
                ' Remove one of the duplicates - combine categories
                If i.Parent.Name = PST Then
                    Set i2 = MAPI.GetItemFromID(dDone(h), target.StoreID)
                    For Each c In Split(i.Categories, "; ")
                        cat = c
                        Set i2 = add_category(i2, cat, target)
                    Next c
                    dDone(h) = i2
                    i.Delete
                Else
                    For Each c In Split(dDone(h).Categories, "; ")
                        cat = c
                        Set i = add_category(i, cat, target)
                    Next c
                    MAPI.GetItemFromID(i.EntryID, target.StoreID).Delete
                    dDone(h) = i.EntryID
                End If
            Else
                Debug.Assert i = MAPI.GetItemFromID(i.EntryID, target.StoreID)
                dDone.Add h, i.EntryID
            End If
            If dDone.Count Mod 1000 = 0 Then Debug.Print dDone.Count; " ";
        Next
    Next
    Debug.Print "done"

    If cache_folder <> "" Then
        import_labels target.Folders(cache_folder), "", dDone, dIMAP, sha1, target, False
    End If

    If final_import Then
        import_labels imap_folder.Folders("[Gmail]").Folders("All Mail"), "", dDone, dIMAP, sha1, target, True
    Else
        import_labels imap_folder, "", dDone, dIMAP, sha1, target, True
    End If
End Sub

Private Function add_category(item, ByVal category As String, target As Outlook.MAPIFolder)
    Set add_category = item
    If category = "" Then Exit Function

    If Left(category, 8) = "[Gmail]/" Then category = Mid(category, 9)
    If category = trash_label Then category = "Trash"

    ' Handle Important separately
    If category = "Important" Then
        item.Importance = olImportanceHigh
        'item.Save
    ElseIf category = "Inbox" Or category = "Trash" Then
        If item.Parent.Name <> category Then
            Set add_category = item.Move(target.Folders(category))
        End If
    ElseIf item.Categories = "" Then
        item.Categories = category
        'item.Save
    ElseIf InStr(", " + item.Categories + ", ", ", " + category + ", ") = 0 Then
        item.Categories = item.Categories + ", " + category
        'item.Save
    End If
End Function

Private Function import_mailitem(i, label As String, _
        dDone As Scripting.Dictionary, dIMAP As Scripting.Dictionary, _
        sha1, target As Outlook.MAPIFolder) As Boolean
    Dim MAPI As Outlook.NameSpace
    Set MAPI = ThisOutlookSession.GetNamespace("MAPI")

    If TypeName(i) = "MailItem" Or TypeName(i) = "AppointmentItem" Or TypeName(i) = "MeetingItem" Then
        Dim i2, d As String

        If dIMAP.Exists(i.EntryID) Then
            d = dIMAP(i.EntryID)
        Else
            d = hashOf(sha1, i)
        End If

        If dDone.Exists(d) Then
            Set i2 = MAPI.GetItemFromID(dDone(d), target.StoreID)
            Debug.Assert i2.Subject = i.Subject
            Debug.Print "["; d; "] "; i2.Subject; " is already imported with categories "; i2.Categories
            Set i2 = add_category(i2, label, target)
            dDone(d) = i2.EntryID
            i2.UnRead = i.UnRead
            i2.Save
            i.Delete
        Else
            Dim UnRead As Boolean
            UnRead = i.UnRead
            Set i2 = i.Move(target)
            Debug.Print "moving ["; d; "] "; i2.Subject; Format(dDone.Count, " (0)")
            Set i2 = add_category(i2, label, target)
            dDone.Add d, i2.EntryID
            i2.UnRead = UnRead
            i2.Save
        End If

        import_mailitem = True
    Else
        Debug.Print "ignoring "; TypeName(i); i.Subject
    End If
End Function

Private Sub import_label(dDone As Scripting.Dictionary, dIMAP As Scripting.Dictionary, _
        folder As Outlook.MAPIFolder, label As String, sha1, _
target As Outlook.MAPIFolder, remote As Boolean)
    Dim i As Variant, items As Outlook.items, N As Integer
    Debug.Print "Importing mail items with label "; label;

    If date_range <> "" Or remote Then
        Dim condition As String
        If remote Then
            Debug.Print " not marked... ";
            condition = "[IMAP Status] = 'Unmarked'"
        End If
        If date_range <> "" Then
            Debug.Print " between "; Replace(date_range, "-", " and "); "... ";
            If condition <> "" Then condition = condition + " And "
            Dim dr
            dr = Split(date_range, "-")
            condition = condition + "[SentOn] >= '" & dr(0) & "' And [SentOn] < '" & dr(1) & "'"
        End If

        Set items = folder.items
        Debug.Print "got items... ";
        Set i = items.Find(condition)
        Debug.Print "searching ...";

        While Not i Is Nothing
            If import_mailitem(i, label, dDone, dIMAP, sha1, target) Then N = N + 1
            Set i = items.FindNext
            Debug.Print label; Format(N, " \#0 ");
        Wend
    Else
        Debug.Print "... "; folder.Name; folder.Parent.Name
        Set items = folder.items
        Debug.Print "got items... ";

        ' local messages get deleted immediately, so we cannot simply loop
        Dim ix
        ix = 1
        While ix <= items.Count
            If import_mailitem(folder.items(ix), label, dDone, dIMAP, sha1, target) Then
                N = N + 1
                If N Mod 100 = 0 Then Debug.Print N;
            Else
                ix = ix + 1
            End If
        Wend
    End If

    Debug.Print "done"

End Sub

Private Sub import_labels(root As Outlook.MAPIFolder, label As String, _
        dDone As Scripting.Dictionary, dIMAP As Scripting.Dictionary, _
        sha1, target As Outlook.MAPIFolder, remote As Boolean)
    Dim f As Variant, folder As Outlook.MAPIFolder
    For Each f In root.Folders
        Set folder = f
        import_labels folder, label + "/" + f.Name, dDone, dIMAP, sha1, target, remote
    Next

    ' We will import All Mail last as it will finally remove the mail.
    ' Also don't import Trash (as it would permanently delete e-mail)
    If label = "" Or label = "/[Gmail]" Or label = "/[Gmail]/All Mail" _
            Then Exit Sub

    import_label dDone, dIMAP, root, Mid(label, 2), sha1, target, remote
End Sub

4. Configure your script

There are a few configuration variables at the top of your script:

IMAP

This is the name of the Outlook root folder where your emails from GMail show up.

PST

This is the name of your target Outlook root folder where you want to migrate your emails to

trash_label

This is the name of your trash label.  If you are importing your Trash with all label information, this is the name of your created label under which you moved the contents of your trash to.  If you are importing your Trash as is, you can enter "Trash" or simply "".

date_range

You have the option to only migrate a portion of your mail, e.g. if you want to only import e-mail from 2011, you would set this to "1/1/2011-1/1/2012".  NOTE: your date format is locale specific, so you need to use your date order.  If you want to migrate all mail, set it to "".  If you are selecting a date range, you should NOT set an IMAP folder size limit.  Otherwise, Outlook may not see all the e-mails from the selected date range.

cache_folder

You might have already copied over your IMAP folders to local folders.  This option allows you to specify the location of the root of the copied folders.  For this script, these have to be a subfolder of your target PST.

NOTE: local migration has not been fully tested.

NOTE 2: do not use this if you have migrated e-mail with categories and now you want to combine these categories.  Instead, simply copy the categorized email into the PST target folder.  Duplicate emails will have their categories merged.  If you do this, pay attention that the Inbox and Trash labels are represented by separate folders, instead of categories.  You need to copy emails with these categories into the respective target sub-folders.

USE_BODY

This script uses the message header of an item to identify it.  I have found this to be unique and it persists across the migration.  If you want to also use the message body, set USE_BODY to 1.   This will slightly slow down the hashing, but it is worth it if you might have messages without message headers.

5. Save your script

Click on the save icon () to save your script.

6. Add the referenced libraries

The script uses two libraries that you have to add to the References.  Select Tools => References.  Look for, and checkmark:

• mscorlib.dll
• Microsoft Scripting Runtime

Now you are ready to start the migration...