Last active
October 7, 2025 15:53
-
-
Save timendum/ba8f8fe47cacb64d5ca00ad799316ec7 to your computer and use it in GitHub Desktop.
Extract meeting info from Outlook to Obsidian
This file contains hidden or 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
| Sub AppendMarkdownUTF8(content As String, strFileName As String) | |
| Dim stream As Object | |
| Dim existingContent As String | |
| Dim strFilePath As String | |
| Dim fso As Object | |
| strFilePath = Environ("USERPROFILE") & "\Documents\Obsidian\Daily\" & strFileName | |
| Set fso = CreateObject("Scripting.FileSystemObject") | |
| ' Create empty file if missing (faster & simpler than ADODB) | |
| If Not fso.FileExists(strFilePath) Then | |
| Dim ff As Integer | |
| ff = FreeFile | |
| Open strFilePath For Output As #ff | |
| Close #ff | |
| existingContent = "" | |
| Else | |
| ' Read existing content | |
| Set stream = CreateObject("ADODB.Stream") | |
| With stream | |
| .Type = 2 ' Text | |
| .Charset = "utf-8" | |
| .Open | |
| .LoadFromFile strFilePath | |
| existingContent = .ReadText | |
| .Close | |
| End With | |
| Set stream = Nothing | |
| End If | |
| ' Write combined content (existing + new) | |
| Set stream = CreateObject("ADODB.Stream") | |
| With stream | |
| .Type = 2 ' Text | |
| .Charset = "utf-8" | |
| .Open | |
| .WriteText existingContent & content | |
| .Position = 0 | |
| .SaveToFile strFilePath, 2 ' 1 = overwrite | |
| .Close | |
| End With | |
| Set stream = Nothing | |
| End Sub | |
| Sub ExtractMeetingInfoToObsidian() | |
| Dim objApp As Outlook.Application | |
| Dim objSelection As Outlook.Selection | |
| Dim objItem As Object | |
| Dim objMeeting As Outlook.AppointmentItem | |
| Dim strMarkdown As String | |
| Dim strAttendees As String | |
| Dim arrAttendees() As String | |
| Dim i As Integer | |
| Dim strFileName As String | |
| Dim sAttendee As String | |
| Set objApp = Outlook.Application | |
| Set objSelection = objApp.ActiveExplorer.Selection | |
| If objSelection.Count = 0 Then | |
| MsgBox "No items selected.", vbExclamation | |
| Exit Sub | |
| End If | |
| Set objItem = objSelection.Item(1) | |
| If Not TypeOf objItem Is Outlook.AppointmentItem Then | |
| MsgBox "Please select a meeting item.", vbExclamation | |
| Exit Sub | |
| End If | |
| Set objMeeting = objItem | |
| ' Extract meeting information | |
| strMarkdown = vbCrLf & "## " & objMeeting.Subject & vbCrLf | |
| strMarkdown = strMarkdown & "- Orario: " & Format(objMeeting.Start, "hh:mm") & " - " & Format(objMeeting.End, "hh:mm") & vbCrLf | |
| strMarkdown = strMarkdown & "- Partecipanti:" & vbCrLf | |
| ' Extract attendees | |
| strAttendees = objMeeting.RequiredAttendees & ";" & objMeeting.OptionalAttendees | |
| arrAttendees = Split(strAttendees, ";") | |
| For i = LBound(arrAttendees) To UBound(arrAttendees) | |
| sAttendee = Trim(arrAttendees(i)) | |
| If sAttendee <> "" Then | |
| If Right(sAttendee, 4) = ", IT" Then | |
| sAttendee = Left(sAttendee, Len(sAttendee) - 4) | |
| End If | |
| strMarkdown = strMarkdown & vbTab & "- " & sAttendee & vbCrLf | |
| End If | |
| Next i | |
| strMarkdown = strMarkdown & vbCrLf | |
| ' Determine file name and path | |
| strFileName = Format(objMeeting.Start, "yyyy-mm-dd") & ".md" | |
| ' Write to file | |
| Call AppendMarkdownUTF8(strMarkdown, strFileName) | |
| End Sub |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment