Outlook Calendar Macro → Markdown

gistfile1.txt

#If VBA7 Then
    Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hWnd As LongPtr) As Long
    Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
    Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
    Private Declare PtrSafe Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As LongPtr) As LongPtr
    Private Declare PtrSafe Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As LongPtr) As LongPtr
    Private Declare PtrSafe Function GlobalLock Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
    Private Declare PtrSafe Function GlobalUnlock Lib "kernel32" (ByVal hMem As LongPtr) As Long
    Private Declare PtrSafe Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As LongPtr
#Else
    Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function EmptyClipboard Lib "user32" () As Long
    Private Declare Function CloseClipboard Lib "user32" () As Long
    Private Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
    Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
    Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
    Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
    Private Declare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long
#End If

Const CF_TEXT = 1
Const GHND = &H42

Sub ExportCalendarToClipboard()
    Dim olApp As Outlook.Application
    Dim olNS As Outlook.NameSpace
    Dim olCalendar As Outlook.Folder
    Dim olItems As Outlook.Items
    Dim olAppt As Outlook.AppointmentItem
    Dim olItem As Object
    Dim startDate As Date
    Dim endDate As Date
    Dim markdown As String
    Dim morningRoutine As String
    Dim eveningRoutine As String
    Dim noteLinkBase As String
    Dim noteLink As String
    Dim firstMeetingTime As Date
    Dim lastMeetingTime As Date
    Dim noteTimestamp As String
    Dim locationText As String
    
    ' Set the date range for today
    startDate = Date
    endDate = Date + 1

    ' Set the base path for notes in Obsidian
    noteLinkBase = "Journal/Notes/" & Format(Date, "yyyy-mmm") & "/"

    ' Get Outlook Calendar folder
    Set olApp = Outlook.Application
    Set olNS = olApp.GetNamespace("MAPI")
    ' enter your email address here
    Set olCalendar = olNS.Folders("[email protected]").Folders("Calendar")

    ' Get items from the calendar
    Set olItems = olCalendar.Items

    ' Sort items by start time
    olItems.Sort "[Start]", False
    olItems.IncludeRecurrences = True

    ' Initialize markdown string
    markdown = ""

    ' Initialize first and last meeting times to a safe default
    firstMeetingTime = #12/31/9999# ' A future date that won't interfere with real meetings
    lastMeetingTime = #1/1/1900# ' A past date that won't interfere with real meetings

    ' Loop through calendar items without Restrict, manually filter
    For Each olItem In olItems
        If TypeName(olItem) = "AppointmentItem" Then
            Set olAppt = olItem
            
            ' Manually filter appointments to today's date
            If Int(olAppt.Start) >= startDate And Int(olAppt.Start) < endDate Then
                ' Determine the first and last meeting times
                If olAppt.Start < firstMeetingTime Then
                    firstMeetingTime = olAppt.Start
                End If
                If olAppt.End > lastMeetingTime Then
                    lastMeetingTime = olAppt.End
                End If
                
                ' Generate the datetime stamp using the current date and time for each note
                noteTimestamp = Format(Now, "yyyyMMddHHmmss")
                
                noteLink = "[Notes](" & noteLinkBase & noteTimestamp & ")"

                ' Text substitution for location
                locationText = olAppt.location
                
                ' Shorten "Microsoft Teams" to "Teams" if there's nothing after it
                If locationText = "Microsoft Teams" Then
                    locationText = "Teams"
                End If
                
                ' Extract room information if the location contains "PREFIX" and a floor/room pattern
                If InStr(locationText, "PREFIX") > 0 Then
                    Dim roomPattern As String
                    roomPattern = Trim(ExtractRoomInfo(locationText))
                    If roomPattern <> "" Then
                        locationText = roomPattern ' Use extracted room info
                    End If
                End If
                
                ' Append appointment to markdown string
                If olAppt.AllDayEvent Then
                    markdown = markdown & "- [ ] " & Format(olAppt.Start, "HH:mm") & " **" & olAppt.Subject & "**" & vbCrLf
                Else
                    markdown = markdown & "- [ ] " & Format(olAppt.Start, "HH:mm") & "-" & Format(olAppt.End, "HH:mm") & " **" & olAppt.Subject & "** *" & locationText & "* " & noteLink & vbCrLf
                End If

                ' Simple delay loop
                Delay 1 ' Introducing a delay of approximately 1 second
            End If
        End If
    Next olItem

    ' Add Morning Routine (2 hours before the first meeting)
    If firstMeetingTime <> #12/31/9999# Then
        morningRoutine = "- [ ] " & Format(firstMeetingTime - (2 / 24), "HH:mm") & " *Morning Routine*" & vbCrLf
        markdown = morningRoutine & markdown
    End If

    ' Add Evening Routine (right after the last meeting)
    If lastMeetingTime <> #1/1/1900# Then
        eveningRoutine = "- [ ] " & Format(lastMeetingTime, "HH:mm") & " *Evening*" & vbCrLf
        markdown = markdown & eveningRoutine
    End If

    ' Copy markdown to clipboard using Windows API
    SetClipboardText markdown

    MsgBox "Markdown list has been copied to the clipboard.", vbInformation
End Sub

Function ExtractRoomInfo(location As String) As String
    On Error Resume Next
    Dim regex As Object
    Set regex = CreateObject("VBScript.RegExp")
    
    ' Define the pattern to match the room info between floors and rooms
    regex.Pattern = "/[12]F\s(.+?)\s\d{1,2}p"
    regex.IgnoreCase = True
    
    If regex.Test(location) Then
        ExtractRoomInfo = regex.Execute(location)(0).SubMatches(0)
    Else
        ExtractRoomInfo = ""
    End If
    
    On Error GoTo 0
End Function

Sub Delay(seconds As Single)
    Dim endTime As Single
    endTime = Timer + seconds
    Do While Timer < endTime
        DoEvents ' Allow other processes to run
    Loop
End Sub

Sub SetClipboardText(text As String)
    Dim hGlobalMemory As LongPtr
    Dim lpGlobalMemory As LongPtr
    Dim hWnd As LongPtr
    Dim hClipMemory As LongPtr

    ' Allocate moveable global memory
    hGlobalMemory = GlobalAlloc(GHND, LenB(text) + 1) ' Use LenB for byte length
    If hGlobalMemory = 0 Then Exit Sub ' If allocation fails, exit

    lpGlobalMemory = GlobalLock(hGlobalMemory)
    If lpGlobalMemory = 0 Then Exit Sub ' If lock fails, exit
    
    lstrcpy lpGlobalMemory, text ' Copy text to global memory
    GlobalUnlock hGlobalMemory

    ' Open the clipboard and empty its contents
    If OpenClipboard(0) Then
        EmptyClipboard
        hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory)
        CloseClipboard
    End If
End Sub

Provided with no warranty.

1. You might need to generate a self-cert for this to work if you company blocks unsigned macros
2. You need to enter you email address
3. The location text is parsed a little

• Microsoft Teams → Teams
• PREFIX removed from room names

4. My note formats are like this: [Notes](Journal/Notes/2024-Aug/20240826012801)

• each note it unique to the second. When I click this link it creates a note in that location named 20240826012801.md