appt that occurs every year for 1hr per day for 10 days

[scadaman29325]

I have an appt every year, for 10 days, that only last an hour.

I can do 1 appt for all day for 10 days every year, but I would like for it to show just 1 hour.

In the past I would make 10 appts that occur every year. Just wondering if there is already a way to do it?

Thanks

[gmayor]

I don't believe that is possible - stick with the 10 appointments. If the occur on the same day each year make them repeating. Otherwise enter the start date and start time of the appointment in the following macro when prompted and it will create 10 appointments:

Sub CreateTenAppts()
Dim i As Integer
Dim vDate As Variant
Dim sDate As String, sTime As String
Const sSubject As String = "Strategy Meeting" 'appointment subject
Const sLocation As String = "Conference Room" 'appointment location
Const sBody As String = "" 'The body text of the appointment
Const lMinutes As Integer = 60 'the length in minutes of the appointment

    sDate = InputBox("Enter start date 'mm/dd/yyyy' :")
    vDate = Split(sDate, "/")
    sTime = InputBox("Enter start time 'hh:mm' :")
    For i = 0 To 9
        sDate = CStr(vDate(0)) & "/" & CStr(Val(vDate(1) + i)) & "/" & CStr(vDate(2))
        CreateAppointment sSubject, sLocation, sBody, sDate, sTime, lMinutes, False
    Next i
lbl_Exit:
    Exit Sub
End Sub


Private Sub CreateAppointment(strSubject As String, _
                              strLocation As String, _
                              strBodyText As String, _
                              strDate As String, _
                              strTime As String, _
                              Optional iMinutes As Integer, _
                              Optional bAllDay As Boolean = True, _
                              Optional strName1 As String, _
                              Optional strName2 As String, _
                              Optional lngStatus As Long = olNonMeeting)

Dim olItem As AppointmentItem
Dim rRequiredAttendee As Recipient
Dim rOptionalAttendee As Recipient
Dim olInsp As Outlook.Inspector
Dim wdDoc As Object
Dim oRng As Object

    Set olItem = CreateItem(olAppointmentItem)
    With olItem
        .MeetingStatus = lngStatus
        .Subject = strSubject
        .Location = strLocation
        .Start = strDate & Chr(32) & strTime        ' & strAMPM
        .Duration = iMinutes
        .AllDayEvent = bAllDay
        'Set rRequiredAttendee = .Recipients.Add(strName1)
        'rRequiredAttendee.Type = olRequired
        'Set rOptionalAttendee = .Recipients.Add(strName2)
        'rOptionalAttendee.Type = olOptional
        .Display
        Set olInsp = .GetInspector
        Set wdDoc = olInsp.WordEditor
        Set oRng = wdDoc.Range
        oRng.Text = strBodyText
    End With
    olItem.Close olSave
    Set olItem = Nothing
    Set rRequiredAttendee = Nothing
    Set rOptionalAttendee = Nothing
    Set olInsp = Nothing
    Set wdDoc = Nothing
    Set oRng = Nothing
lbl_Exit:
    Exit Sub
End Sub

[scadaman29325]

Thanks, Phil.