Example code illustrating the use of Tim Hall's Excel JSON classes in Microsoft Outlook

CouchDb

' Functions to read/write CouchDB on localhost
' @dependencies: Reference to 'Microsoft Scripting Runtime', RestHelpers (https://github.com/timhall/Excel-REST)

' VBA Ref: http://msdn.microsoft.com/en-us/library/gg251755%28v=office.15%29.aspx
' Outlook VBA Ref: http://msdn.microsoft.com/en-US/library/ee861520%28v=office.15%29.aspx

Option Explicit


' Replace back-ticks with double quotes for producing valid JSON
Function fixUpQuotedString(str As String) As String
    fixUpQuotedString = Replace(str, "`", """")
End Function

Sub testNextUid()
    Debug.Print CouchDbGetNextUid()
End Sub
' Return a new Document ID from local CouchDB
Function CouchDbGetNextUid() As String
    Dim couchClient As New RestClient
    Dim Response As RestResponse
    
    couchClient.BaseUrl = "http://127.0.0.1:5984/"
    Set Response = couchClient.GetJSON("_uuids?count=1")
    
    If Response.StatusCode = Ok Then
        CouchDbGetNextUid = Response.Data("uuids")(1)
    Else
        Debug.Print "Error: " & Response.Content
        CouchDbGetNextUid = "ERROR"
    End If
     
    Set Response = Nothing
    Set couchClient = Nothing
     
End Function

' Write Email Metadata to CouchDB
Sub WriteCouchDB(out As Dictionary)
    
    Dim couchClient As New RestClient
    Dim rRequest As New RestRequest
    Dim rResponse As RestResponse
    
    'On Error Resume Next
    
    'Dim Resource As String
    couchClient.BaseUrl = "http://127.0.0.1:5984/"
    
    'rRequest.Resource = Resource
    rRequest.Resource = "mailstats2/" & out.Item("_id") ' rRequest.Resource = "mailstats2" '
    out.Remove "_id"
    rRequest.Method = httpPUT ' rRequest.Method = httpPOST '
    rRequest.Format = json
    rRequest.AddBody out
    
    
    Set rResponse = couchClient.Execute(rRequest)
    ' rResponse.
    '   StatusCode = Created, StatusDescription = "Created"
    '   Data("ok") = true
    '   Data("id"), Data("rev")
    ' rResponse.Headers(1)("key") = "Cache-Control", .Headers(1)("value") = "must-revalidate"
    If rResponse.StatusCode = Created Then
        Debug.Print out("Direction"), " - ID: ", rResponse.Data("id"), " REV: ", rResponse.Data("rev")
    Else
        Debug.Print out("Direction"), " - Status Code: ", rResponse.StatusCode, "Status Description: ", rResponse.StatusDescription
    End If
    
    Set rRequest = Nothing
    Set rResponse = Nothing
    Set couchClient = Nothing
    
End Sub
Sub WriteCouchDB2(out As Dictionary, id As String)
    
    Dim couchClient As New RestClient
    Dim rRequest As New RestRequest
    Dim rResponse As RestResponse
    
    'On Error Resume Next
    
    ' update handler
    '/<database>/_design/<design>/_update/<function>/<docid>
    
    'Dim Resource As String
    couchClient.BaseUrl = "http://127.0.0.1:5984/"
    
    'rRequest.Resource = Resource
    rRequest.Resource = "mailstats3/_design/test/_update/in-place/" & id ' rRequest.Resource = "mailstats2" '
    'out.Remove "_id"
    rRequest.Method = httpPUT ' rRequest.Method = httpPOST '
    rRequest.Format = json
    rRequest.AddBody out
    
    
    Set rResponse = couchClient.Execute(rRequest)
    On Error Resume Next
    ' rResponse.
    '   StatusCode = Created, StatusDescription = "Created"
    '   Data("ok") = true
    '   Data("id"), Data("rev")
    ' rResponse.Headers(1)("key") = "Cache-Control", .Headers(1)("value") = "must-revalidate"
    If rResponse.StatusCode = Created Then
        Debug.Print "B", out("Direction"), " - ID: ", rResponse.Data("id"), " REV: ", rResponse.Data("rev")
    Else
        Debug.Print "B", out("Direction"), " - Status Code: ", rResponse.StatusCode, "Status Description: ", rResponse.StatusDescription
        Debug.Print " ", rResponse.Content
    End If
    
    Set rRequest = Nothing
    Set rResponse = Nothing
    Set couchClient = Nothing
    
End Sub
Sub LogIncoming(olItem As Outlook.MailItem)
    Debug.Print "Recieved ", TypeName(olItem)
    If TypeOf olItem Is MailItem Then LogToCouch olItem, "Received"
End Sub

Sub LogToCouch(olItem As Object, direction As String)
    Dim strToCcBcc As String
    Dim out As New Dictionary
    Dim strTo As String
    Dim strCc As String
    Dim strBcc As String
    Dim Recipient As Outlook.Recipient
    Dim x As Variant
    
    'olitem
    '   BCC, BodyFormat, Categories, Body, CC, Class, ConversationID
    '   ConversationTopic, CreationTime, DeferredDeliveryTime, ExpiryTime
    '   FlagDueBy, FlagIcon, FlagRequest, FlagStatus, Importance,
    '   LastModificationTime, ReadRecieptRequested, RecievedByName
    '   RecievedTime, SenderEmailAddress, SenderName, SenderEmailType
    '   SentOn, Size, Subject, To, Attachments, EntryID
    '   Importance, FlagRequest, FlagStatus (Int), IsMarkedAsTask (bool), REminderTime
    '   ReceivedByName, ReceivedOnBehalfOfName
    '   Parent.FolderPath
    If TypeOf olItem Is MeetingItem Then
        ' Types: olOptional, olOrganizer, olRequired, or olResource.
        For Each Recipient In olItem.Recipients
            Select Case Recipient.Type
                Case olRequired, olOrganizer
                    strTo = strTo & Recipient.Name & "<" & Recipient.Address & ">;"
                Case olOptional, olResource
                    strCc = strCc & Recipient.Name & "<" & Recipient.Address & ">;"
            End Select
        Next Recipient
        If Right(strTo, 1) = ";" Then strTo = Left(strTo, Len(strTo) - 1) ' remove trailing ;
        If Right(strCc, 1) = ";" Then strCc = Left(strCc, Len(strCc) - 1) ' remove trailing ;
        If Right(strBcc, 1) = ";" Then strBcc = Left(strBcc, Len(strBcc) - 1) ' remove trailing ;
        
        strToCcBcc = olItem.Recipients.Item(1).Name & "<" & olItem.Recipients.Item(1).Address & ">"
        Debug.Print "TO ", strTo, " CC ", strCc, " BCC ", strBcc
    Else
        strToCcBcc = Replace(olItem.To & ";" & olItem.CC & ";" & olItem.BCC, ";;", ";") ' all destinations
Debug.Print "2"
        x = Split(olItem.To, ";")
Debug.Print "2a"
        'strTo = RestHelpers.ConvertToJSON(Split(olItem.To, ";"))
        Debug.Print "3"
        'strCc = RestHelpers.ConvertToJSON(Split(olItem.CC, ";"))
        'strBcc = RestHelpers.ConvertToJSON(Split(olItem.BCC, ";"))
        'Debug.Print "TO ", strTo, " CC ", strCc, " BCC ", strBcc
    End If
    If Right(strToCcBcc, 1) = ";" Then strToCcBcc = Left(strToCcBcc, Len(strToCcBcc) - 1) ' remove trailing ;
    strToCcBcc = "[""" & Replace(strToCcBcc, ";", """,""") & """]"
    
    'On Error Resume Next ' Don't stop!
    
    Debug.Print "10"
    ' Build a dictionary object of data - will be converted to JSON later
    out.Add "Account", "ACCOUNT NAME HERE" ' @TODO: Make this dynamic
    out.Add "ID", olItem.EntryID
    out.Add "Type", TypeName(olItem)
    out.Add "Direction", direction
    out.Add "Received", Format(olItem.ReceivedTime, "yyyy-mm-ddTHH:MM:ss")
    out.Add "From", olItem.SenderName & " <" & olItem.SenderEmailAddress & ">"
    out.Add "ToAll", strToCcBcc
    out.Add "To", strTo
    out.Add "CC", strCc
    out.Add "BCC", strBcc
    out.Add "Sent", Format(olItem.SentOn, "yyyy-mm-ddTHH:MM:ss")
    out.Add "Subject", olItem.Subject
    out.Add "Attachments", olItem.Attachments.count
    out.Add "ConversationID", olItem.ConversationID
    out.Add "ConversationIndex", olItem.ConversationIndex
    out.Add "ConversationTopic", olItem.ConversationTopic
    out.Add "CreationTime", Format(olItem.CreationTime, "yyyy-mm-ddTHH:MM:ss")
    out.Add "DeferredDeliveryTime", Format(olItem.DeferredDeliveryTime, "yyyy-mm-ddTHH:MM:ss")
    out.Add "ExpiryTime", Format(olItem.ExpiryTime, "yyyy-mm-ddTHH:MM:ss")
    out.Add "LastModificationTime", Format(olItem.LastModificationTime, "yyyy-mm-ddTHH:MM:ss")
    out.Add "Size", olItem.Size
    out.Add "Importance", olItem.Importance
    out.Add "FlagRequest", olItem.FlagRequest
    out.Add "FlagStatus", olItem.FlagStatus ' (Int)
    out.Add "IsMarkedAsTask", olItem.IsMarkedAsTask ' (bool)
    out.Add "ReminderTime", Format(olItem.ReminderTime, "yyyy-mm-ddTHH:MM:ss")
    out.Add "ReceivedByName", olItem.ReceivedByName
    out.Add "ReceivedOnBehalfOfName", olItem.ReceivedOnBehalfOfName
    out.Add "FolderPath", olItem.Parent.FolderPath
    out.Add "_id", olItem.ConversationIndex

    WriteCouchDB out
    WriteCouchDB2 out, olItem.ConversationIndex
End Sub

ThisOutlookSession

' Example code to trigger record of all incoming and outgoing email

Option Explicit

Public WithEvents inboxItems As Outlook.Items
Public WithEvents oInspectors As Outlook.Inspectors
Public WithEvents oMsg As Outlook.MailItem

' Triggered by sending mail - single entries only
' Note that this happens BEFORE the item is actually sent so Send Date is null
Private Sub Application_ItemSend(ByVal olItem As Object, Cancel As Boolean)
    On Error Resume Next
    Debug.Print "Sent ", TypeName(olItem)
    ' Only log actual mail (not calendar, etc)
    Call CouchDB.LogToCouch(olItem, "Send")
    
End Sub

' Triggered by incoming mail
' Note: May recieve multiple entries at once
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)

    Dim olItem As Object
    Dim intInitial As Integer
    Dim intFinal As Integer
    Dim strEntryId As String
    Dim intLength As Integer
    
    On Error Resume Next
    
    'Debug.Print EntryIDCollection
    
    intInitial = 1
    intLength = Len(EntryIDCollection)
    intFinal = InStr(intInitial, EntryIDCollection, ",")
    
    ' Handle single entry
    If intFinal = 0 Then
        Set olItem = Application.Session.GetItemFromID(EntryIDCollection)
        Debug.Print "Received ", TypeName(olItem)
        Call CouchDB.LogToCouch(olItem, "Receive")
    End If
    
    ' Handle multiple entries
    Do While intFinal <> 0
        strEntryId = Strings.Mid(EntryIDCollection, intInitial, (intFinal - intInitial))
        
        Set olItem = Application.Session.GetItemFromID(strEntryId)
        Call CouchDB.LogToCouch(olItem, "Receive")
        
        Debug.Print "Received ", TypeName(olItem)
        
        intInitial = intFinal + 1
        intFinal = InStr(intInitial, EntryIDCollection, ",")
    Loop
    
    strEntryId = Strings.Mid(EntryIDCollection, intInitial, (intLength - intInitial) + 1)

    Set olItem = Nothing

End Sub