Microsoft Outlook troubleshooting

Często w życiu zawodowym musimy wykonać pewne czynności jakie zostały opisane w przesłanych na nasza skrzynkę wiadomościach.  

O ile zadanie takie możemy wykonać od razu, to po jego wykonaniu możemy wysłać odpowiedź do zainteresowanego. W przypadku jednak, kiedy czynności takie mają rozłożyć się w czasie, to do wykonania zadania potrzebna jest nam często zakopana w gąszczu innych wiadomości oryginalna treść oraz załączniki. Można przyjąć iż przeciągnięcie wiadomości utworzy nam obiekt, jednakże nie wypełni go załącznikami jak i również nie przypisze parametrów do obiektu (np. zadaną datą wykonania) a będzie się jedynie odnosić do jednej, pierwotnej wiadomości.
 
Poniższa procedura przedstawia możliwość utworzenia wydarzenia kalendarzowego lub zadania, na podstawie zaznaczonych wiadomości (może ich być kilka), oddalonego w czasie o określoną liczbę dni. 
Option Explicit

Sub Wywolanie()
    Call Create_Appointment_or_Task(False, 3)
End Sub

Sub Create_Appointment_or_Task(ByVal Calendar_no_Task As Boolean, ByVal TimeInterval&)
    Dim objItem As MailItem
    Dim objJob As Object
    Dim x&, Entry As Collection
    On Error Resume Next
    MkDir ("c:\temp")
    Const AttPath$ = "C:\Temp\"

    On Error GoTo blad
    Entry = New Collection
    If objItem Is Nothing Then
        With ActiveExplorer.Selection
            For x = 1 To .Count
                If .item(x).Class <> 43 Then GoTo opusc
                DoEvents
                objItem = .item(x)
                objItem.SaveAs (AttPath & objItem.EntryID)
                Entry.Add (objItem.EntryID)
opusc:
            Next x
        End With
    End If

    If Calendar_no_Task = True Then
        objJob = CreateItem(olAppointmentItem)
    Else
        objJob = CreateItem(olTaskItem)
    End If

    With objJob
        If Calendar_no_Task = True Then
            .Start = Now + TimeInterval
            .End = Now + TimeInterval
        Else
            .Status = olTaskInProgress
            .DueDate = Now + TimeInterval
            .StartDate = Now + TimeInterval
            .ReminderTime = Now + TimeInterval
        End If
        .Subject = "Przypomnienie o: " & objItem.Subject
        .Categories = "VBATools.pl"
        .Importance = objItem.Importance
        .ReminderSet = True
        .Body = "Przygotowano " & Now & " na podstawie wiadomości email:" & vbCr
        For x = 1 To Entry.Count
            DoEvents
            objJob.Attachments.Add AttPath & Entry.item(x), olEmbeddeditem
            Kill (AttPath & Entry.item(x))
        Next
        .Display 'lub .Save jeśli nie chcemy widzieć obiektu
    End With
    Exit Sub
blad:
    MsgBox "Błąd wykonania:" & Err.Number & vbCr & _
            Err.Description, vbExclamation, "VBATools.pl"
End Sub

Aby rozszerzyć funkcjonalność można podpiąć procedurę do formy z umieszczonym datownikiem lub zautomatyzować o stałą liczbę dni i bez wyświetlania obiektu zapisać go w Outlooku.
 
Można też osadzić procedurę „Create_Appointment_or_Task” pod przyciskiem w menu MS Outlook i uruchamiać ja skrótem klawiszowym, polecam uwadze ten artykuł.
Osadzenie procedury znajdziecie w artykule: Instalacja i uruchamianie makr.

MVP Shon Oskar – VBATools.pl
Jeśli masz pytania dot. tego artykułu zapraszam na Forum
Skonfiguruj swój pakiet dodatków do Excela, Worda, PowerPointa i Outlooka



© Wszelkie prawa zastrzeżone. Żadna część ani całość tego artykułu nie może być powielana ani publikowana bez zgody autora.