Uruchomienie interfejsu zaplanowane jest tak, aby realizowała opisane pow. zadanie na otwartej wiadomości email.

 

Uruchomienie powyższej procedury, spowoduje wywołanie formy (Rys.1.) składającej się z: dwóch pól tekstowych, jednego checkboxa, kontrolki TimePicker (z pakietu biblioteki mscomct2.ocx), jednego przycisku, siedmiu etykiet oraz pięciu Combo boxów.

 

Rys.1. Interfejs programu tworzącego przypomnienie o wydarzeniu.

 

Aby samodzielnie przygotować środowisko do tego zadania należy się zapoznać z poniższym kodem VBA umieszczonym w formie interfejsu:

 

Option Explicit On

Private Sub Anuluj_Click()
    Unload(Me)
End Sub

Private Sub DTPicker1_Change()
    Call wlacz_wstaw()
End Sub

Private Sub Godzina_do_Change()
    If Format(Godzina_od.text, "HH") > Format(Godzina_do.text, "HH") Then _
    Godzina_od.text = Godzina_do.text
End Sub

Private Sub Godzina_od_Change()
    If Format(Godzina_od.text, "HH") > Format(Godzina_do.text, "HH") Then _
    Godzina_do.text = Godzina_od.text
End Sub

Private Sub Przypomnienie_ustaw_Click()
    If Przypomnienie_ustaw.value = True Then
        Przypomnienie.Enabled = True
    Else
        Przypomnienie.Enabled = False
    End If
End Sub

Private Sub Sala_Change()
    Call wlacz_wstaw()
End Sub

Private Sub Temat_Change()
    Call wlacz_wstaw()
End Sub

Private Sub wlacz_wstaw()
    If Len(Trim(Temat.text)) > 0 And Len(Trim(Sala.text)) > 0 And _
        Format(DTPicker1.value, "YYYY-MM-DD") >= Format(Now, "YYYY-MM-DD") Then
        Wstaw.Enabled = True
    Else
        Wstaw.Enabled = False
    End If
End Sub

Private Sub UserForm_Initialize()
    DTPicker1.value = Now
    Dim x&
    For x = 0 To 240
        Przypomnienie.AddItem(x)
        x = x + 9
    Next x
    Przypomnienie.ListIndex = 0
    For x = 8 To 21
        Godzina_od.AddItem(x & ":00")
        Godzina_od.AddItem(x & ":30")
        Godzina_do.AddItem(x & ":00")
        Godzina_do.AddItem(x & ":30")
    Next x
    Godzina_od.text = Format(Now, "HH") & ":00"
    Godzina_do.text = Format(Now, "HH") & ":00"

    Call listLocation()
End Sub

Private Sub listLocation()
    Dim colCalendar As Outlook.Items, aItems As AppointmentItem, NoDupes As New Collection, _
        x&, jest As Boolean, i&, j&, Swap1, Swap2, item
    colCalendar = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderCalendar).Items
    For Each aItems In colCalendar
        DoEvents()
        jest = False
        If Len(Trim(aItems.LOCATION)) = 0 Then GoTo nastepny
        If NoDupes.Count = 0 Then NoDupes.Add(aItems.LOCATION)
        For x = 1 To NoDupes.Count
            If UCase(NoDupes(x)) = UCase(Trim(aItems.LOCATION)) Then jest = True
        Next x
        If jest = False Then NoDupes.Add(Trim(aItems.LOCATION))
nastepny:
    Next

    For i = 1 To NoDupes.Count - 1
        For j = i + 1 To NoDupes.Count
            If NoDupes(i) > NoDupes(j) Then
                Swap1 = NoDupes(i)
                Swap2 = NoDupes(j)
                NoDupes.Add(Swap1, before:=j)
                NoDupes.Add(Swap2, before:=i)
                NoDupes.Remove(i + 1)
                NoDupes.Remove(j + 1)
            End If
        Next j
    Next i

    For Each item In NoDupes
        Sala.AddItem(item)
    Next item
End Sub

Private Sub Wstaw_Click()
    Dim F&, file$, Katalog$, strDestFolderPath$
    F = FreeFile

    Katalog = "C:\Temp"
    On Error Resume Next
    MkDir(Katalog)
    On Error GoTo 0

    strDestFolderPath = Katalog & "\" & "Przypomnienie.ics"
    If FileExists(strDestFolderPath) = True Then Kill(strDestFolderPath)

        Open strDestFolderPath For Output As #F
            Print #F, "BEGIN: VCALENDAR"
            Print #F, "BEGIN: VEVENT"
            Print #F, "DTSTART:" & Format(DTPicker1.value, "YYYYMMDD") & _
                    "T" & Replace(Godzina_od.text, ":", vbNullString) & "00"
            Print #F, "DTEND:" & Format(DTPicker1.value, "YYYYMMDD") & _
                    "T" & Replace(Godzina_do.text, ":", vbNullString) & "00"
            Print #F, "SUMMARY: " & Trim(Temat.text)
            Print #F, "LOCATION: " & Trim(Sala.text)
            Print #F, "DESCRIPTION; ENCODING=QUOTED-PRINTABLE:" & _
                Replace(Info.text, xhr(13) & xhr(10), "=0D=0A=0D=0A") & "=0D=0A=0D=0A"
    If Przypomnienie_ustaw.value = True Then
                Print #F, "BEGIN: VALARM"
                Print #F, "TRIGGER:-PT" & Przypomnienie.text & "M"
                Print #F, "ACTION: Display"
    End If
            Print #F, "DESCRIPTION: Reminder"
            Print #F, "End: VALARM"
            Print #F, "End: VEVENT"
            Print #F, "End: VCALENDAR"
        Close #F

    If FileExists(strDestFolderPath) = True Then
        Dim olMail As MailItem
        olMail = Application.ActiveInspector.CurrentItem

        olMail.Attachments.Add(strDestFolderPath)
        olMail = Nothing
    End If
    Unload(Me)
End Sub