|
Option Explicit |
|
Private Declare PtrSafe Function CoCreateGuid Lib "ole32" (ByRef GUID As Byte) As Long |
|
Private has_more As Boolean |
|
|
|
Public Sub SendToJoplin() |
|
Dim sToken As String |
|
Dim sUrl As String |
|
Dim sMailFolderName As String |
|
Dim sNotesFolderName As String |
|
|
|
sToken = "REPLACE ME WITH YOUR TOKEN" |
|
sUrl = "http://127.0.0.1:41184" |
|
sMailFolderName = "Outlook Mail" |
|
sNotesFolderName = "Outlook Notes" |
|
|
|
Dim sMailFolderID As String |
|
Dim sNotesFolderID As String |
|
Dim oNoteIDs |
|
Set oNoteIDs = CreateObject("Scripting.Dictionary") |
|
sMailFolderID = "" |
|
sNotesFolderID = "" |
|
|
|
Dim nExport As Integer |
|
Dim nError As Integer |
|
nExport = 0 |
|
nError = 0 |
|
|
|
Dim oItem As Object ' Outlook.MailItem or Outlook.PostItem or Outlook.DocumentItem or Outlook.NoteItem |
|
For Each oItem In Application.ActiveExplorer.Selection |
|
Dim sJSONString As String |
|
Dim sItemID As String |
|
|
|
If TypeOf oItem Is Outlook.MailItem Or TypeOf oItem Is Outlook.PostItem Or TypeOf oItem Is Outlook.DocumentItem Then |
|
|
|
If sMailFolderID = "" Then |
|
sMailFolderID = CreateJoplinItem("folder", sMailFolderName, sUrl, sToken) |
|
If sMailFolderID = "" Then Return |
|
End If |
|
|
|
Dim sAttachmentInfo As String |
|
sAttachmentInfo = ImportAttachments(oItem, sUrl, sToken) |
|
sJSONString = HttpRequest(sUrl & "/notes?token=" & sToken, "POST", "{ " _ |
|
& """is_todo"": 0, ""title"": """ & EscapeBody(oItem.ConversationTopic) & """" _ |
|
& ", ""parent_id"": """ & sMailFolderID & """" _ |
|
& ", ""user_created_time"": """ & ToUnixTime(oItem.CreationTime) & """" _ |
|
& ", ""user_updated_time"": """ & ToUnixTime(UpdateTime(oItem)) & """" _ |
|
& ", """ & IIf(IsHtml(oItem), "body_html", "body") & """: """ & EscapeBody(MakeBody(oItem, sAttachmentInfo)) & """" _ |
|
& " }") |
|
sItemID = ParseJsonResponse(sJSONString, "id", "AddNote") |
|
|
|
ElseIf TypeOf oItem Is Outlook.NoteItem Then |
|
|
|
If sNotesFolderID = "" Then |
|
sNotesFolderID = CreateJoplinItem("folder", sNotesFolderName, sUrl, sToken) |
|
If sNotesFolderID = "" Then Return |
|
End If |
|
|
|
sJSONString = HttpRequest(sUrl & "/notes?token=" & sToken, "POST", "{ " _ |
|
& """is_todo"": 0, ""title"": """ & EscapeBody(oItem.Subject) & """" _ |
|
& ", ""parent_id"": """ & sNotesFolderID & """" _ |
|
& ", ""user_created_time"": """ & ToUnixTime(oItem.CreationTime) & """" _ |
|
& ", ""user_updated_time"": """ & ToUnixTime(oItem.LastModificationTime) & """" _ |
|
& ", ""body"": """ & EscapeBody(oItem.Body) & """" _ |
|
& " }") |
|
sItemID = ParseJsonResponse(sJSONString, "id", "AddNote") |
|
|
|
Else |
|
MsgBox "Outlook " & TypeName(oItem) & " is not supported: " & oItem.Subject |
|
sItemID = "" |
|
End If |
|
|
|
If sItemID <> "" Then |
|
nExport = nExport + 1 |
|
Debug.Print nExport & " " & EscapeBody(oItem.Subject) |
|
Else |
|
nError = nError + 1 |
|
End If |
|
|
|
|
|
If oItem.Categories <> "" And sItemID <> "" Then |
|
Dim aCategories() As String |
|
aCategories = Split(oItem.Categories, ", ") |
|
Dim vCategory As Variant |
|
For Each vCategory In aCategories |
|
Dim sCategory As String |
|
Dim sTagID As String |
|
sCategory = vCategory |
|
If oNoteIDs.Exists(sCategory) Then |
|
sTagID = oNoteIDs.item(sCategory) |
|
Else |
|
sTagID = CreateJoplinItem("tag", sCategory, sUrl, sToken) |
|
oNoteIDs.Add sCategory, sTagID |
|
End If |
|
If sTagID = "" Then |
|
nError = nError + 1 |
|
Else |
|
sJSONString = HttpRequest(sUrl & "/tags/" & sTagID & "/notes?token=" & sToken, "POST", "{ ""id"": """ & sItemID & """ }") |
|
Dim sTaggedID As String |
|
sTaggedID = ParseJsonResponse(sJSONString, "id", "AddNote") |
|
If sTaggedID = "" Then |
|
nError = nError + 1 |
|
End If |
|
End If |
|
Next |
|
End If |
|
Next |
|
Dim sMsg As String |
|
sMsg = nExport & " notes exported to Joplin folder " |
|
If sMailFolderID = "" Then |
|
sMsg = sMsg & """" & sNotesFolderName & """" |
|
ElseIf sNotesFolderID = "" Then |
|
sMsg = sMsg & """" & sMailFolderName & """" |
|
Else |
|
sMsg = sMsg & """" & sNotesFolderName & """ and """ & sMailFolderName & """" |
|
End If |
|
If nError = 0 Then |
|
MsgBox sMsg |
|
Else |
|
MsgBox nError & " errors encountered. " & sMsg |
|
End If |
|
End Sub |
|
|
|
Private Function UpdateTime(oItem As Object) As Date |
|
If TypeOf oItem Is Outlook.DocumentItem Then |
|
UpdateTime = oItem.LastModificationTime |
|
Else |
|
UpdateTime = oItem.ReceivedTime |
|
End If |
|
End Function |
|
|
|
Private Function ImportAttachments(oItem As Object, sUrl As String, sToken As String) As String |
|
Dim oAttachment As Object |
|
Dim sTemp As String |
|
Dim sJSONString As String |
|
Dim sFileID As String |
|
|
|
ImportAttachments = "" |
|
sTemp = Environ("TEMP") |
|
For Each oAttachment In oItem.Attachments |
|
Dim sSaveFile As String |
|
sSaveFile = sTemp & "\" & NewGuid() |
|
If InStrRev(oAttachment.FileName, ".") > 0 Then sSaveFile = sSaveFile & Mid(oAttachment.FileName, InStrRev(oAttachment.FileName, ".")) |
|
oAttachment.SaveAsFile sSaveFile |
|
sJSONString = HttpUpload(sUrl & "/resources?token=" & sToken, sSaveFile, "{ ""title"":""" & oAttachment.DisplayName & """ }") |
|
Kill sSaveFile |
|
sFileID = ParseJsonResponse(sJSONString, "id", "ImportAttachments") |
|
If ImportAttachments <> "" Then ImportAttachments = ImportAttachments & ", " |
|
If IsHtml(oItem) Then |
|
ImportAttachments = ImportAttachments & "<a href=""" & sFileID & """>" & oAttachment.FileName & "</a>" |
|
Else |
|
ImportAttachments = ImportAttachments & "[" & oAttachment.FileName & "](:/" & sFileID & ")" |
|
End If |
|
Next |
|
End Function |
|
|
|
Private Function IsHtml(oItem As Object) As Boolean |
|
If TypeOf oItem Is Outlook.DocumentItem Then |
|
IsHtml = False |
|
Else |
|
IsHtml = (oItem.BodyFormat = olFormatHTML) |
|
End If |
|
End Function |
|
|
|
Private Function MakeBody(oItem As Object, sAttachmentInfo As String) As String |
|
Dim sFrom As String |
|
Dim sNl As String |
|
|
|
If Not (TypeOf oItem Is Outlook.DocumentItem) Then |
|
sFrom = oItem.SenderEmailAddress |
|
If oItem.SenderName <> "" Then |
|
If sFrom <> "" And oItem.SenderEmailType = "SMTP" Then |
|
sFrom = oItem.SenderName & " <" & sFrom & ">" |
|
Else |
|
sFrom = oItem.SenderName |
|
End If |
|
End If |
|
End If |
|
If IsHtml(oItem) Then |
|
MakeBody = oItem.HTMLBody |
|
sFrom = EscapeHtml(sFrom) |
|
sNl = "<br/>" & vbLf |
|
Else |
|
MakeBody = oItem.Body |
|
sNl = vbLf |
|
End If |
|
If sAttachmentInfo <> "" Then MakeBody = "Attachments: " & sAttachmentInfo & sNl & sNl & MakeBody |
|
If TypeOf oItem Is Outlook.MailItem Then |
|
If oItem.To <> "" Then |
|
If sAttachmentInfo = "" Then MakeBody = sNl & MakeBody |
|
MakeBody = "To: " & oItem.To & sNl & MakeBody |
|
If sFrom <> "" Then MakeBody = "From: " & sFrom & sNl & MakeBody |
|
End If |
|
End If |
|
End Function |
|
|
|
Private Function EscapeBody(sText As String) 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 + vbLf, "\n") 'Carriage return + Newline is replaced with \n |
|
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 EscapeHtml(sText As String) As String |
|
EscapeHtml = sText |
|
EscapeHtml = Replace(EscapeHtml, "&", "&") |
|
EscapeHtml = Replace(EscapeHtml, "<", "<") |
|
EscapeHtml = Replace(EscapeHtml, ">", ">") |
|
End Function |
|
|
|
Private Function FindJoplinItem(sType As String, sItemName As String, sUrl As String, sToken As String) As String |
|
Dim page As Integer |
|
|
|
page = 1 |
|
Do |
|
Dim sJSONString As String |
|
Dim aItems As Variant |
|
sJSONString = HttpRequest(sUrl & "/search?query=" & sItemName & "&type=" & sType & "&page=" & page & "&token=" & sToken) |
|
page = page + 1 |
|
aItems = ParseJsonResponse(sJSONString, "items", "FindJoplinItem") |
|
|
|
If IsArray(aItems) Then |
|
Dim jItem As Variant |
|
For Each jItem In aItems |
|
If VarType(jItem) = vbObject Then |
|
If jItem.Exists("id") And jItem.Exists("title") And jItem.Exists("parent_id") Then |
|
' Debug.Print jItem.Item("id") & " " & jItem.item("title") |
|
If jItem.item("parent_id") = "" And LCase(jItem.item("title")) = LCase(sItemName) Then |
|
FindJoplinItem = jItem.item("id") |
|
Exit Function |
|
End If |
|
End If |
|
End If |
|
Next |
|
End If |
|
Loop While has_more |
|
FindJoplinItem = "" |
|
End Function |
|
|
|
Private Function CreateJoplinItem(sType As String, sItemName As String, sUrl As String, sToken As String) As String |
|
|
|
CreateJoplinItem = FindJoplinItem(sType, sItemName, sUrl, sToken) |
|
If CreateJoplinItem <> "" Then Exit Function |
|
|
|
Dim sJSONString As String |
|
sJSONString = HttpRequest(sUrl & "/" & sType & "s?token=" & sToken, "POST", "{ ""title"": """ & EscapeBody(sItemName) & """ }") |
|
CreateJoplinItem = ParseJsonResponse(sJSONString, "id", "CreateJoplinItem") |
|
End Function |
|
|
|
Private Function ParseJsonResponse(sJSONString As String, sItem As String, sOp As String) |
|
Dim vJSON As Variant |
|
Dim sState As String |
|
|
|
has_more = False |
|
JSON.Parse sJSONString, vJSON, sState |
|
ParseJsonResponse = "" |
|
If sState <> "Object" Then |
|
MsgBox sOp & ": invalid response from Joplin server: " & sJSONString |
|
ElseIf vJSON.Exists("error") Then |
|
MsgBox sOp & " error: " & vJSON.item("error") |
|
ElseIf Not vJSON.Exists(sItem) Then |
|
MsgBox sOp & ": no item """ & sItem & """ in response from Joplin server: " & sJSONString |
|
Else |
|
ParseJsonResponse = vJSON.item(sItem) |
|
End If |
|
If vJSON.Exists("has_more") Then |
|
has_more = vJSON.item("has_more") |
|
End If |
|
End Function |
|
|
|
Private Function HttpRequest(sUrl As String, Optional sMethod As String = "GET", Optional sPost As String = "") As String |
|
Dim sResponse As String |
|
|
|
With CreateObject("Msxml2.ServerXMLHTTP") |
|
.Open sMethod, sUrl, False |
|
.setRequestHeader "Cache-Control", "no-cache" |
|
.setRequestHeader "Pragma", "no-cache" |
|
.Send sPost |
|
Do Until .ReadyState = 4: DoEvents: Loop |
|
sResponse = .ResponseText |
|
End With |
|
' Debug.Print sResponse & " <- " & sMethod & " " & sURL & " " & sPost |
|
HttpRequest = sResponse |
|
End Function |
|
|
|
Private Function HttpUpload(sUrl As String, sFileName As String, sPost As String) As String |
|
' upload file based on XMLHTTP example from https://wqweto.wordpress.com/2011/07/12/vb6-using-wininet-to-post-binary-file/ |
|
Dim STR_BOUNDARY As String |
|
STR_BOUNDARY = "SendToJoplin-" & NewGuid() |
|
Dim fileNo As Integer |
|
Dim baFileData() As Byte |
|
Dim sResponse As String |
|
|
|
' read file |
|
fileNo = FreeFile |
|
Open sFileName For Binary Access Read As fileNo |
|
If LOF(fileNo) > 0 Then |
|
ReDim baFileData(0 To LOF(fileNo) - 1) As Byte |
|
Get fileNo, , baFileData |
|
End If |
|
Close fileNo |
|
|
|
' upload file |
|
With CreateObject("Msxml2.ServerXMLHTTP") |
|
.Open "POST", sUrl, False |
|
.setRequestHeader "Cache-Control", "no-cache" |
|
.setRequestHeader "Pragma", "no-cache" |
|
.setRequestHeader "Content-Type", "multipart/form-data; boundary=" & STR_BOUNDARY |
|
.Send CombineArrays( _ |
|
pvToByteArray( _ |
|
"--" & STR_BOUNDARY & vbCrLf & _ |
|
"Content-Disposition: form-data; name=""props""" & vbCrLf & vbCrLf & _ |
|
sPost & vbCrLf & _ |
|
"--" & STR_BOUNDARY & vbCrLf & _ |
|
"Content-Disposition: form-data; name=""data""; filename=""" & Mid(sFileName, InStrRev(sFileName, "\") + 1) & """" & vbCrLf & _ |
|
"Content-Type: application/octet-stream" & vbCrLf & vbCrLf _ |
|
), _ |
|
baFileData, _ |
|
pvToByteArray(vbCrLf & "--" & STR_BOUNDARY & "--") _ |
|
) |
|
Do Until .ReadyState = 4: DoEvents: Loop |
|
sResponse = .ResponseText |
|
End With |
|
' Debug.Print sResponse |
|
HttpUpload = sResponse |
|
End Function |
|
|
|
Public Function CombineArrays(ParamArray arraysToMerge() As Variant) As Byte() |
|
' Adapted from https://stackoverflow.com/a/51407942/6199960 |
|
Dim CombinedArrayLength As Long |
|
Dim i As Long, j As Long |
|
|
|
CombinedArrayLength = 0 |
|
For i = LBound(arraysToMerge) To UBound(arraysToMerge) |
|
CombinedArrayLength = CombinedArrayLength + (UBound(arraysToMerge(i)) - LBound(arraysToMerge(i)) + 1) |
|
Next i |
|
|
|
Dim combinedArray() As Byte |
|
ReDim combinedArray(0 To CombinedArrayLength - 1) |
|
|
|
Dim combinedArrayIndex As Long |
|
combinedArrayIndex = LBound(combinedArray) |
|
For i = LBound(arraysToMerge) To UBound(arraysToMerge) |
|
For j = LBound(arraysToMerge(i)) To UBound(arraysToMerge(i)) |
|
combinedArray(combinedArrayIndex) = arraysToMerge(i)(j) |
|
combinedArrayIndex = combinedArrayIndex + 1 |
|
Next j |
|
Next i |
|
' Debug.Print StrConv(combinedArray, vbUnicode) |
|
CombineArrays = combinedArray |
|
End Function |
|
|
|
Private Function pvToByteArray(sText As String) As Byte() |
|
pvToByteArray = StrConv(sText, vbFromUnicode) |
|
End Function |
|
|
|
Private Function NewGuid() As String |
|
' based on https://stackoverflow.com/a/23126614/6199960 |
|
Dim ID(0 To 15) As Byte |
|
Dim N As Integer |
|
Dim GUID As String |
|
Dim Res As Long |
|
|
|
Res = CoCreateGuid(ID(0)) |
|
For N = 0 To 15 |
|
GUID = GUID & Right("0" & Hex(ID(N)), 2) |
|
If N = 3 Or N = 5 Or N = 7 Or N = 9 Then GUID = GUID & "-" |
|
Next N |
|
NewGuid = GUID |
|
End Function |
|
|
|
Private Function ToUnixTime(ByVal dt As Date) As LongLong |
|
' ToUnixTime convert Date value in the local timezone to Unix timestamp in milliseconds, UTC |
|
' Based on example from https://gist.github.com/seakintruth/ddcc3d5e400a5083458494ae30d55466 |
|
Dim objDateTime |
|
Set objDateTime = CreateObject("WbemScripting.SWbemDateTime") |
|
objDateTime.SetVarDate dt |
|
ToUnixTime = DateDiff("s", "01/01/1970 00:00:00", CDate(objDateTime.GetVarDate(False))) * 1000 + Fix((dt - Fix(dt)) * 1000) |
|
' Debug.Print dt & Format(dt - Fix(dt), ".000") & " -> " & ToUnixTime |
|
End Function |