• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

outlooka görev atama

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

C++: 
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
 
Ö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.
 
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.

230326


C++: 
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
 
Üstad sorunsuz çalışıyor. teşekkür ederim ellerinize sağlık. iyi hafta sonları dilerim.
 

Ekli dosyalar

ÖmerFaruk' Alıntı:
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


C++: 
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
Genişletmek için tıkla ...

Ömer Bey Merhaba,,,
Sütunlarda mevcut olan "Durum ve Hatırlatma" ne anlama geliyor.
 
Sorunuzun direkt cevaplarını Microsoft Outlook uygulamanızda yeni görev ekleyek görebilirsiniz.
 
ÖmerFaruk' Alıntı:
Sorunuzun direkt cevaplarını Microsoft Outlook uygulamanızda yeni görev ekleyek görebilirsiniz.
Genişletmek için tıkla ...
Outlook malesef tabletimde yüklü değil. Bİlgi amaçlı sormuştum. Cevabınız için teşekkürler.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst