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