Private Sub cmdAfspraak_Click()
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim outObj As Outlook.Application
Dim outAccount As Outlook.Account
Dim getNamespace As Outlook.NameSpace
Dim OutAppt As Outlook.AppointmentItem
Dim outTask As Outlook.TaskItem
Dim i As Integer, iA As Variant
Set outObj = Outlook.Application
For Each outAccount In outObj.Session.Accounts
MsgBox outAccount.DisplayName & vbLf & outAccount.SmtpAddress
If outAccount = "Microsoft Exchange" Then
Set getNamespace = outObj.getNamespace("MAPI")
getNamespace.Logon "MyProfile", , False
If Me.cboType = "Taak" Then
If Me.txtDatum < DateAdd("ww", 26, Date) Then Exit Sub
iA = Array(0, 1, 3, 6, 12, 26)
Set outObj = CreateObject("Outlook.Application")
For i = 0 To 5
If Me.chkAddedToOutlook = False Then
Set outTask = outObj.CreateItem(olTaskItem)
With outTask
.StartDate = DateAdd("ww", -iA(i), DateValue(Me.txtDatum))
.Subject = Me.txtSubject
.Body = Nz(Me.txtApptNotes, "")
.Sensitivity = olPrivate
If Me.txtReminder.Value > 0 Then
.ReminderMinutesBeforeStart = Nz(Me.txtApptReminderDuration, 15)
.ReminderSet = True
End If
.Save
If Me.Dirty Then Me.Dirty = False
End With
End If
Next i
Set outTask = Nothing
Set outObj = Nothing
Me.AddedToOutlook = True
Else
If Me.chkAddedToOutlook = False Then
Set OutAppt = outObj.CreateItem(olAppointmentItem)
With OutAppt
''.Visible = True
.Start = DateValue(Me.txtDatum) + TimeValue(Me.txtTijd)
.Duration = Me.txtApptDuration.Value
.Subject = Me.txtSubject
.Body = Nz(Me.txtApptNotes, "")
.Location = Nz(Me.txtApptLocation, "")
.Sensitivity = olPrivate
If Me.txtReminder.Value > 0 Then
.ReminderMinutesBeforeStart = Nz(Me.txtApptReminderDuration, 15)
.ReminderSet = True
End If
''.Display
.Save
Me.AddedToOutlook = True
If Me.Dirty Then Me.Dirty = False
End With
Set outObj = Nothing
Set OutAppt = Nothing
End If
Me.cmdSluiten.SetFocus
Me.cmdAfspraak.Enabled = False
End If
End If
Next
End Sub