ms3056 · August 26, 2024 04:28 · ms3056 · Aug 26, 2024
diff --git a/gistfile1.txt b/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("your@email.com").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
	#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("your@email.com").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