CreateTentativeWorkAppointment.bas

' Creates an appointment to block timeslits in the Outlook calendar for tasks
' 
' In case an email is selected
'   - this email is put as attachment and as body of the appointment
'   - deleted afterwards
Sub CreateTentativeWorkAppointment()
    Dim oView As Outlook.View
    Dim olApp As Outlook.Application
    Dim olApt As Outlook.AppointmentItem
    Dim olSelection As Outlook.Selection
    
    Set olApp = CreateObject("Outlook.Application")
    Set olSelection = olApp.ActiveExplorer.Selection
    
    Set oExpl = Application.ActiveExplorer
    Set oView = oExpl.CurrentView
    
    Set olApt = olApp.CreateItem(olAppointmentItem)
    With olApt
        .ReminderSet = False
        .Subject = "[work] "
        .Sensitivity = olConfidential
        .BusyStatus = olTentative
        .Categories = "[work]"
    End With

    If oView.ViewType = olCalendarView Then
        Dim datStart As Date
        Dim datEnd As Date
        Dim oCalView As Outlook.CalendarView

        Set oCalView = oExpl.CurrentView
        datStart = oCalView.SelectedStartTime
        datEnd = oCalView.SelectedEndTime
        
        olApt.Start = datStart
        olApt.End = datEnd
    Else
        Dim nextHalfHour As Date
        nextHalfHour = DateAdd("n", 30, Now())
        nextHalfHour = DateSerial(Year(nextHalfHour), Month(nextHalfHour), Day(nextHalfHour)) + TimeSerial(Hour(nextHalfHour), 30 * (Int(Minute(nextHalfHour) / 30) + 1), 0)
        
        olApt.Start = nextHalfHour
        olApt.Duration = 60
    End If
    
    If (oView.ViewType = olTableView) And (olSelection.count = 1) Then
        Dim olEmail As Outlook.MailItem
        Set olEmail = olSelection.item(1)
        olApt.Attachments.Add olEmail, olByValue, 1, olEmail.Subject
        
        olApt.Body = olEmail.Body
        
        olEmail.Delete
        olApt.Save
    End If
    
    olApt.Display
End Sub