Send Outlook email to Joplin

README.md

Export to Joplin

The main code was lightly adapted from here. Consult these instructions, but use the code from this project.

Some notes:

• Make sure that you have access to the Developer settings in Outlook

• Open Visual Basic from the developer ribbon

• Under Microsoft Outlook Objects, double click ThisOutlookSession

• Copy the code in ThisOutlookSession.cls into ThisOutlookSession.

• For this code to work, download and add to the project the JSON.bas file from here

• Add a shortcut to the Outlook ribbon for this macro

If the code is working properly, you should be able to highlight a message, click the shortcut button, and send the message to the chosen folder.

ThisOutlookSession.cls

Option Explicit

' Code from https://gist.github.com/ramisedhom/0f34c5d6a8d73f0b98ac4bea2ec30be0#gistcomment-4128720
' Modified to be suitable for Joplin as of 20220412
' Some minor enhancements were made along the way
Public Sub SendToJoplin()
    Dim sToken As String, sURL As String
    Dim sURLNotes, sURLResources, sEscapedBody, sJSONString, sFolderID, sFolderResponse As String
    Dim objItem As Outlook.MailItem
    
    sToken = "YOUR_TOKEN_HERE"
    sURL = "http://127.0.0.1:41184"
    sURLNotes = sURL & "/notes?token=" & sToken
    sURLResources = sURL & "/resources?token=" & sToken

    For Each objItem In ActiveExplorer.Selection
        sEscapedBody = EscapeBody( _
                "Date: " & objItem.ReceivedTime & "<br>" _
                & "To: " & objItem.To & "<br>" _
                & objItem.HTMLBody)
                
        sFolderID = GetFolderIDFromJoplin(sToken, sURL)
                
        With CreateObject("MSXML2.XMLHTTP")
            .Open "POST", sURLNotes, False
            .Send "{ ""title"": """ & objItem.ConversationTopic & """" _
            & ", ""parent_id"": """ & sFolderID & """" _
            & ", ""body_html"": """ & sEscapedBody & """" _
            & " }"
            Do Until .ReadyState = 4: DoEvents: Loop
                sJSONString = .ResponseText
        End With
    Next
    'Debug.Print sJSONString 'Uncomment to see joplin response
End Sub

Private Function EscapeBody(sText As String)
    EscapeBody = sText
    EscapeBody = Replace(EscapeBody, "\", "\\")                 'Backslash is replaced with \\
    EscapeBody = Replace(EscapeBody, Chr(34), "\" & Chr(34))    'Double quote is replaced with \"
    EscapeBody = Replace(EscapeBody, vbCr, "\r")                'Carriage return is replaced with \r
    EscapeBody = Replace(EscapeBody, vbLf, "\n")                'Newline is replaced with \n
    EscapeBody = Replace(EscapeBody, Chr(8), "\b")              'Backspace is replaced with \b
    EscapeBody = Replace(EscapeBody, Chr(12), "\f")             'Form feed is replaced with \f
    EscapeBody = Replace(EscapeBody, vbTab, "\t")               'Tab is replaced with \t
End Function

Private Function GetFolderIDFromJoplin(sToken As String, sURL As String)
    'Input token, url
    'Output folder id
    
    Dim sJSONString, sMessage, sIntroMessage, sFullMessage, sTitle, sDefault, sMyChoice As String
    Dim vJSON As Variant
    Dim sState As String
    Dim aData(), aHeader()
    Dim i, iFirstRow, iLastRow, iBlockSize, iFirstNameLoc, iName, iID, iNumFolders As Integer
    Dim FolderDict As Variant
    Set FolderDict = CreateObject("Scripting.Dictionary")

    sURL = sURL & "/folders?token=" & sToken
    
    'Get folders list
    With CreateObject("MSXML2.XMLHTTP")
        .Open "GET", sURL, False
        .Send
        Do Until .ReadyState = 4: DoEvents: Loop
            sJSONString = .ResponseText
    End With
    Debug.Print sJSONString
    'Parse JSON response
    json.Parse sJSONString, vJSON, sState
    json.ToArray vJSON, aData(), aHeader()
    
    ' The json parsing code was not changed from the original
    ' Unfortunately, it doesn't work as intended and I don't have the wherewithal to understand and fix it
    ' Attempts to replace it failed, so accommodation was in order
    ' With the current code, the json string is parsed into a 2D array, aData
    ' Notes:
    '   - column 1 of the array is not useful to us
    '   - the first entry of column 0, aData(0,0), contains the object key to the structure ("items")
    '   - the rows we care about are in groups of three, as implemented in the iStep variable below
    '   - as of now, the entries of interest are
    '       aData(0, 1)    id of first folder
    '       aData(0, 3)    name of first folder
    '       aData(0, 4)    id of second folder
    '       aData(0, 6)    name of first folder
    '       aData(0, 3i-2) id of ith folder
    '       aData(0, 3i)   name of ith folder

    sIntroMessage = "Enter one of the following in the box below:"
    sMessage = ""
    iFirstRow = LBound(aData, 2)    ' the 2 here refers to the row-wise index
    iLastRow = UBound(aData, 2)
    iBlockSize = 3
    iNumFolders = (iLastRow - iFirstRow - 1) / iBlockSize
    iFirstNameLoc = 3    ' row index of first name
    For i = 1 To iNumFolders
        iName = 3 * i   ' row index of folder name
        iID = 3 * i - 2 ' row index of folder ID
        FolderDict.Add aData(0, iName), aData(0, iID)
        sMessage = sMessage & vbTab & "- " & aData(0, iName) & vbLf
    Next i
    sFullMessage = sIntroMessage & vbLf & sMessage
    sTitle = "Choose Joplin folder..."
    sDefault = aData(0, iFirstNameLoc)
    sMyChoice = InputBox(sFullMessage, sTitle, sDefault)
    If FolderDict.Exists(sMyChoice) Then
        GetFolderIDFromJoplin = FolderDict(sMyChoice)
    Else
        MsgBox "Error: Your choice """ & sMyChoice & """ was not found among the folders. Export has failed."
        GetFolderIDFromJoplin = ""
    End If
End Function