Sub Outlook_Takvime_Gonder()
Dim EvnOUT As Object, OutRandevu As Object, say As Long
say = 0
For s = 3 To Range("C65536").End(xlUp).Row
If Cells(s, "B") <> "OK" Then
On Error Resume Next
Set EvnOUT = GetObject(, "Outlook.Application")
If Err.Number = 429 Then
Set EvnOUT = CreateObject("Outlook.application")
End If
On Error GoTo 0
Set OutRandevu = EvnOUT.CreateItem(1)
On Error Resume Next
With OutRandevu
.Start = Cells(s, "C") + Cells(s, "D")
.End = Cells(s, 5) + Cells(s, 6)
.Subject = Cells(s, 7)
.Location = Cells(s, 8)
.Body = Cells(s, "I")
If Len(Cells(s, "J")) > 0 Then
If IsNumeric(Cells(s, "J")) Then
.ReminderMinutesBeforeStart = Cells(s, "J")
.ReminderSet = True
End If
End If
If Err <> 0 Then
Cells(s, "B") = "HATA"
Else
.Save
Cells(s, "B") = "OK"
Err = 0
say = say + 1
End If
End With
Set EvnOUT = Nothing
Set OutRandevu = Nothing
End If
Next s
If say > 0 Then
MsgBox say & " adet kayıt aktarıldı.", vbInformation
Else
MsgBox "Aktarılan kayıt yok!", vbExclamation
End If
End Sub
Örnek excel_dosyası indir
