View Single Post
 
Old 11-18-2015, 10:12 PM
gmayor's Avatar
gmayor gmayor is offline Windows 7 64bit Office 2010 32bit
Expert
 
Join Date: Aug 2014
Posts: 4,138
gmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud of
Default

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)

Code:
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
__________________
Graham Mayor - MS MVP (Word) (2002-2019)
Visit my web site for more programming tips and ready made processes www.gmayor.com
Reply With Quote