Forked from ramisedhom/Send email from Outlook to Joplin.bas
Last active
March 3, 2024 00:27
-
-
Save nabaco/bb9acb327deb25090d7b9a44d8d3ed2a to your computer and use it in GitHub Desktop.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Private Sub Cancel_Click() | |
Me.Cancel = True | |
Unload Me | |
End Sub | |
Private Sub OK_Click() | |
Unload Me | |
End Sub |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Public Sub SendToJoplin() | |
Dim sToken As String, sURL As String | |
Dim sURLNotes, sURLResources, sEscapedBody, sJSONString, sFolderID As String | |
Dim objItem As Outlook.MailItem | |
sToken = "REPLACE WITH YOUR TOKEN" | |
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>" _ | |
& "From: " & objItem.Sender & "<br>" _ | |
& "To: " & objItem.To & "<br>" _ | |
& "CC: " & objItem.CC & "<br>" _ | |
& "BCC: " & objItem.BCC & "<br>" _ | |
& objItem.HTMLBody) | |
sFolderID = GetFoldersFromJoplin(sToken, sURL) | |
If IsEmpty(sFolderID) Then | |
Exit Sub | |
End If | |
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 GetFoldersFromJoplin(sToken As String, sURL As String) | |
'Input token, url | |
'Output folder id | |
Dim sJSONString, sMyChoice As String | |
Dim vJSON As Variant | |
Dim sState As String | |
Dim aData(), aHeader() | |
Dim i, hieght As Integer | |
Dim OpBtn(20) As MSForms.OptionButton | |
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 | |
'Parse JSON response | |
JSON.Parse sJSONString, vJSON, sState | |
JSON.ToArray vJSON, aData(), aHeader() | |
'Display a choices of folders | |
height = 100 | |
For i = LBound(aData) To UBound(aData) | |
'Add Dynamic OptionButton and assign it to object 'OpBtn' | |
Set OpBtn(i) = fChooseNoteboo.Controls.Add("Forms.OptionButton.1") | |
With OpBtn(i) | |
.Caption = aData(i, 2) | |
.Name = "oNotebook" & i | |
.Top = 25 + i * 25 | |
.Left = 25 | |
End With | |
height = height + 25 | |
Next i | |
fChooseNoteboo.height = height | |
fChooseNoteboo.OK.Top = height - 60 | |
fChooseNoteboo.Cancel.Top = height - 60 | |
fChooseNoteboo.Show | |
If fChooseNoteboo.Cancel.Cancel = True Then | |
Exit Function | |
End If | |
For i = LBound(aData) To UBound(aData) | |
If OpBtn(i).Value = "True" Then | |
GetFoldersFromJoplin = aData(i, o) | |
Exit For | |
End If | |
Next i | |
End Function |
For some reason the Notebooks list doesn't get updated when a notebook as added or deleted.
Any progress on this? I wasn't able to get it installed as a Macro on Outlook 365, the fChooseNoteboo.OK.Top = height - 60
is not found according to the debugger.
I stopped using Joplin. You're free to play with the code if you wish.
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment
Follow these instructions for the code to work:
https://gist.github.com/ramisedhom/0f34c5d6a8d73f0b98ac4bea2ec30be0#gistcomment-3123273
All credits go to the original author, I have just improved the notebook selection GUI.
Additionally, you'll need to manually create a form, such as this:
The sizes don't matter, as we set them dynamically from the code. I have called it fChooseNoteboo, in the properties panel:
BTW, that's not a typo, VBA gave me troubles for some reason, but if you rename it, adapt the code accordingly