VBATools

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łącznikiem(kami) 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), oddalonym w czasie o określoną liczbę dni. Aby zapisać wydarzenie kalendarzowe wystarczy parametr wywołania procedury ustawić na True/Zadania na False. Długość dni odroczenia określa się liczbą drugiego parametru.

Option Explicit 

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

Private Sub Create_Appointment_or_Task(Calendar_no_Task As Boolean, TimeInterval&)
'MVP OShon from VBATools.pl
 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
 Set 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
 Set 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
   Set objJob = CreateItem(olAppointmentItem)
 Else
   Set 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ę „Wywolanie” 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.

(c) Shon Oskar – www.VBATools.pl