outlooka görev atama

[spacebar]

değerli üstadlarım. daha önce işlenen bir konu ancak eksikleri var. yardımcı olmanızı rica ederim.
yapılması istenen: belgede istenen görevleri tekrarsız bir şekilde outlooka atamak.
teşekkürler...

https://www.excel.web.tr/threads/outlook-uezerine-alarm-kur.184071/

 

[ÖmerFaruk]

Verilen harici linkteki işleme uygun bir tablo yerine, farklı içerik ve formatlara sahip bir tablo kullanmışsınız.
Özellikle C-D-E-F-G sütunlarınızın formatlarını örneğe uydurabilirsiniz.

CheckBox eklemek silmek yerine daha pratik bir yol izlenebilir. Mesela K sütununda Ekle / Eklendi / "Boş" gibi (boşluk) 3 seçenekli bir veri doğrulama koyabilirsiniz. (Tablonuzun formatını düzeltince K sütununu da en son sütun olarak düzeltebilirsiniz)

Harici linkteki tabloya uygun olarak bahsettiğim sütunun 8. sütuna denk gelecek şekilde ayarlarsanız orjinal kodlara 3 ilave satırla bu işi yapabileceğiniz düşünüyorum. Eklediğim 3 satır ve revize attığım 1 satırı kodların içinde yanına ifade yazarak belirttim

Sub AddAppointments()
'Update by Extendoffice 20180608
    Dim I As Long
    Dim xRg As Range
    Dim xOutApp As Object
    Dim xOutItem As Object
    Set xOutApp = CreateObject("Outlook.Application")
    Set xRg = Range("A2:H" & Range("A" & Rows.Count).End(xlUp).Row) ' Tablo alanınızı revize ettim
    For I = 1 To xRg.Rows.Count
        If xRg.Cells(I, 7).Value <> "EKLE" Then GoTo Devam1 'Eklediğim Satır
        Set xOutItem = xOutApp.createitem(1)
        Debug.Print xRg.Cells(I, 1).Value
        xOutItem.Subject = xRg.Cells(I, 1).Value
        xOutItem.Location = xRg.Cells(I, 2).Value
        xOutItem.Start = xRg.Cells(I, 4).Value
        xOutItem.Duration = xRg.Cells(I, 5).Value
        If Trim(xRg.Cells(I, 6).Value) = "" Then
            xOutItem.BusyStatus = 2
        Else
            xOutItem.BusyStatus = xRg.Cells(I, 6).Value
        End If
        If xRg.Cells(I, 7).Value > 0 Then
            xOutItem.ReminderSet = True
            xOutItem.ReminderMinutesBeforeStart = xRg.Cells(I, 7).Value
        Else
            xOutItem.ReminderSet = False
        End If
        xRg.Cells(I, 7).Value = "EKLENDİ" 'Eklediğim Satır
        xOutItem.Body = xRg.Cells(I, 8).Value
        xOutItem.Save
        Set xOutItem = Nothing
Devam1: 'Eklediğim Satır
    Next
    Set xOutApp = Nothing
End Sub

 

[spacebar]

Ömer Faruk Bey üstadım merhaba. orjinal linkteki örnekten tek farkı tarih sütunu eklendi. onu da tekrar atanmasından kaçınmak için kolaylık olacağını düşündüm. ikinci tarih sutununu çıkarıp sizin kodları eklediğimde makro çalışmadı. kodları sutun numaralarına göre tek tek kontrol ettiğimde bazı hatalar buldum düzelttim ancak yine çalışmadı. ilginiz için teşekkür eder sağlıklı günler dilerim.

 

[ÖmerFaruk]

Deneme yapmamıştım. Kodların da çalıştığını varsaymıştım.
Bir kaç yerde düzeltme ve ekleme yaptım. Sayfa formatını aşağıdaki şekilde düzenledim
Çokça test etmedim ancak ilk görevi ekledi hatta süresi geçti diye Outlook hemen uyarı verdi.
Geliştirmek mümkün.

Sub AddAppointments()
'Update by Extendoffice 20180608
    Dim i As Long
    Dim xRg As Range
    Dim xOutApp As Object
    Dim xOutItem As Object
    Set xOutApp = CreateObject("Outlook.Application")
    Set xOutItem = xOutApp.CreateItem(olAppointmentItem)
    Set xRg = Range("A2:H" & Range("A" & Rows.Count).End(xlUp).Row)
    For i = 1 To xRg.Rows.Count
        If xRg.Cells(i, 8).Value <> "EKLE" Then GoTo Devam1 'Eklediğim Satır
        Set xOutItem = xOutApp.CreateItem(1)
        Debug.Print xRg.Cells(i, 1).Value
        xOutItem.Subject = xRg.Cells(i, 1).Value
        xOutItem.Location = xRg.Cells(i, 2).Value
        xOutItem.Start = xRg.Cells(i, 3).Value
        xOutItem.Duration = xRg.Cells(i, 4).Value
        If Trim(xRg.Cells(i, 5).Value) = "" Then
            xOutItem.BusyStatus = 2
        Else
            xOutItem.BusyStatus = xRg.Cells(i, 5).Value
        End If
        If xRg.Cells(i, 6).Value > 0 Then
            xOutItem.ReminderSet = True
            xOutItem.ReminderMinutesBeforeStart = xRg.Cells(i, 6).Value
        Else
            xOutItem.ReminderSet = False
        End If
        xRg.Cells(i, 8).Value = "EKLENDİ" 'Eklediğim Satır
        xOutItem.Body = xRg.Cells(i, 7).Value
        xOutItem.Save
        Set xOutItem = Nothing
Devam1: 'Eklediğim Satır
    Next
    Set xOutApp = Nothing
End Sub

 

[spacebar]

Üstad sorunsuz çalışıyor. teşekkür ederim ellerinize sağlık. iyi hafta sonları dilerim.

 

[Utekiner]

Deneme yapmamıştım. Kodların da çalıştığını varsaymıştım.
Bir kaç yerde düzeltme ve ekleme yaptım. Sayfa formatını aşağıdaki şekilde düzenledim
Çokça test etmedim ancak ilk görevi ekledi hatta süresi geçti diye Outlook hemen uyarı verdi.
Geliştirmek mümkün.

Ekli dosyayı görüntüle 230326

Sub AddAppointments()
'Update by Extendoffice 20180608
    Dim i As Long
    Dim xRg As Range
    Dim xOutApp As Object
    Dim xOutItem As Object
    Set xOutApp = CreateObject("Outlook.Application")
    Set xOutItem = xOutApp.CreateItem(olAppointmentItem)
    Set xRg = Range("A2:H" & Range("A" & Rows.Count).End(xlUp).Row)
    For i = 1 To xRg.Rows.Count
        If xRg.Cells(i, 8).Value <> "EKLE" Then GoTo Devam1 'Eklediğim Satır
        Set xOutItem = xOutApp.CreateItem(1)
        Debug.Print xRg.Cells(i, 1).Value
        xOutItem.Subject = xRg.Cells(i, 1).Value
        xOutItem.Location = xRg.Cells(i, 2).Value
        xOutItem.Start = xRg.Cells(i, 3).Value
        xOutItem.Duration = xRg.Cells(i, 4).Value
        If Trim(xRg.Cells(i, 5).Value) = "" Then
            xOutItem.BusyStatus = 2
        Else
            xOutItem.BusyStatus = xRg.Cells(i, 5).Value
        End If
        If xRg.Cells(i, 6).Value > 0 Then
            xOutItem.ReminderSet = True
            xOutItem.ReminderMinutesBeforeStart = xRg.Cells(i, 6).Value
        Else
            xOutItem.ReminderSet = False
        End If
        xRg.Cells(i, 8).Value = "EKLENDİ" 'Eklediğim Satır
        xOutItem.Body = xRg.Cells(i, 7).Value
        xOutItem.Save
        Set xOutItem = Nothing
Devam1: 'Eklediğim Satır
    Next
    Set xOutApp = Nothing
End Sub

Ömer Bey Merhaba,,,
Sütunlarda mevcut olan "Durum ve Hatırlatma" ne anlama geliyor.

 

[ÖmerFaruk]

Sorunuzun direkt cevaplarını Microsoft Outlook uygulamanızda yeni görev ekleyek görebilirsiniz.

 

[Utekiner]

Sorunuzun direkt cevaplarını Microsoft Outlook uygulamanızda yeni görev ekleyek görebilirsiniz.

Outlook malesef tabletimde yüklü değil. Bİlgi amaçlı sormuştum. Cevabınız için teşekkürler.