Hello,
with this code the system creats an entry in the tasklist/to do list (in german Aufgabenliste) and therefore it doesnt appear in the task overwiew in outlook today. how do i have to change that this code creates a task and no entry in the task list - sorry
for my english ;-) Thank you Martin
Public Sub ToDo()
'Due: tomorrow, 8 o'clock
MarkItemasTask 0
End Sub
Public Sub MarkItemasTask(ByVal AddDays As Long, _
Optional TimeOfDay As String = "08:00", _
Optional Subject As String, _
Optional Mail As Outlook.MailItem _
)
Dim oulOrdnerZiel As Outlook.MAPIFolder
Set Ns = Application.GetNamespace("MAPI")
Set objApp = Application
Set oulOrdnerZiel = Ns.GetDefaultFolder(olFolderInbox).folders("ToDo")
'Set oulOrdnerZiel = Ns.folders("Ablage").folders("2020")
Dim Items As VBA.Collection
Dim obj As Object
Dim i As Long
Dim dt As Date
Dim tm As String
Dim Icon As OlMarkInterval
dt = DateAdd("d", AddDays, Date)
tm = CStr(dt) & " " & TimeOfDay
If AddDays < 1 Then
Icon = olMarkToday
ElseIf AddDays = 1 Then
Icon = olMarkTomorrow
ElseIf Weekday(Date, vbUseSystemDayOfWeek) + AddDays < 8 Then
Icon = olMarkThisWeek
Else
Icon = olMarkNextWeek
End If
If Mail Is Nothing Then
Set Items = GetCurrentItems
Else
Set Items = New VBA.Collection
Items.Add Mail
End If
For Each obj In Items
If TypeOf obj Is Outlook.MailItem Then
Set Mail = obj
Mail.MarkAsTask Icon
Mail.TaskStartDate = tm
Mail.TaskDueDate = tm
If Len(Subject) Then
Mail.TaskSubject = Subject
Mail.FlagRequest = Subject
End If
Mail.ReminderTime = tm
Mail.ReminderSet = False
Mail.Save
Mail.Move oulOrdnerZiel
End If
Next
Set objApp = Nothing
Set Ns = Nothing
End Sub
