Create Calendar Item though VBA

[komobu]

Hi;

I would like to create a calendar item through vba so that much of my items will already be filled in. I also want to increase the font size in the item.

I am hoping to click on an icon in the ribbon (Which will run a macro), and a macro will create a new event with the subject of "Vehicle Inspection", Start Time would be current date & Time (Nearest 1/2hour), The default duration would be one hour and the AllDay Event would not be checked.

In the body of the calendar item I would like the font set to arial 16, and these 3 lines:

VIN:
Od:
Plate:

is this possible?

Any help would be appreciated.

[gmayor]

The following macro and function will do that. You will have to add the button to the context sensitive Calendar ribbon. Remove the apostrophe from the start of the line where indicated after testing, (unless you want to add to the body of the appointment item)

Option Explicit

Sub CreateAppointment()
Dim strStartTime As String
Dim strEndTime As String
    strStartTime = Format((Round(Now() * 48, 0) / 48), "hh:mm")
    strEndTime = Format(DateAdd("n", 60, CDate(strStartTime)), "hh:mm")
    AddOutlookApptmnt Date, Date, strStartTime, strEndTime, "Vehicle Inspection", "VIN:" & vbCr & vbCr & "Od:" & vbCr & vbCr & "Plate:"
lbl_Exit:
    Exit Sub
End Sub


Private Sub AddOutlookApptmnt(sStartDate As String, _
                              sEndDate As String, _
                              sStartTime As String, _
                              sEndTime As String, _
                              sSubject As String, _
                              sBody As String, _
                              Optional sLocation As String)

Dim objAppt As Outlook.AppointmentItem
Dim objInsp As Outlook.Inspector
Dim objDoc As Object
Dim oRng As Object
Dim datStartDate As Date
Dim datEndDate As Date
Const BodyFont As String = "Arial"
Const BodySize As Long = 16
    datStartDate = CDate(sStartDate & " " & sStartTime)
    datEndDate = CDate(sEndDate & " " & sEndTime)

    Set objAppt = CreateItem(1)        'appointment
    With objAppt
        .Start = datStartDate
        .End = datEndDate
        .ReminderSet = True
        .AllDayEvent = False
        .Subject = sSubject
        .Location = sLocation
        .Display
        Set objInsp = objAppt.GetInspector
        Set objDoc = objInsp.WordEditor
        Set oRng = objDoc.Range(0, 0)
        oRng.Text = sBody
        oRng.Font.Name = BodyFont
        oRng.Font.Size = BodySize
        .BusyStatus = 0
        'objInsp.Close 0 ' reinstate when you are happy with the result
    End With
CancelledByUser:            'Error handler
    If Err.Number > 0 Then
        MsgBox "Cancelled By User", , "Operation Cancelled"
    End If
    Set objAppt = Nothing
    Set objInsp = Nothing
    Set objDoc = Nothing
    Set oRng = Nothing
lbl_Exit:
    Exit Sub
End Sub

[komobu]

Hi Graham;

This looks great! Thanks you so very much.

[komobu]

Hi again Graham.

I am really thankful of the code you posted.

Not sure if this is possible, but is there a way to set the cursor position immediately after the "Vin: " instead of the "Location" field. If there isnt, no big deal. I was just wondering if there may be a way to do it.

Thanks again