Private Sub KAYDET_Click()

On Error GoTo Err_KAYDET_Click

Dim strCurrent As String

Dim objApp As New Outlook.Application

Dim outappt As Outlook.AppointmentItem

DoCmd.RunCommand acCmdSaveRecord

 

On Error Resume Next

 

 Set objApp = GetObject(, "Outlook.Application")

 If Err <> 0 Then

 Set objApp = CreateObject("outlook.Application")

 Err.Clear

 End If

 

 Set outappt = objApp.CreateItem(olAppointmentItem)

 With outappt

 .Start = DateAdd("d", -1, CDate(Me.MONTAJ_TARİHİ)) & " " & CDate(Time())

 .Duration = 10 'başlangıç bitiş tarihi arasındaki süre (dakika)

 .Subject = Me.MÜŞTERİ_ADI_ÜNVANI

 .Body = Me.ADRESI

 .Location = "Hatırlatıcı"

 .ReminderMinutesBeforeStart = 60 ' hatırlatıcı süresi (dakika)

 .ReminderSet = True

 .Save

 End With

 

DoCmd.RunCommand acCmdSaveRecord

 If MsgBox("Randevu Eklendi, randevu bilgileri açılsın mı", vbInformation + vbYesNo, "Randevu Eklendi...") = vbYes Then

 outappt.Display

 Else

 outobj.Quit

 End If

Set outobj = Nothing

Exit_KAYDET_Click:

Exit Sub

Err_KAYDET_Click:

MsgBox "Error " & Err.Number & vbCrLf & Err.Description

Resume Exit_KAYDET_Click

End Sub