Excel Forum
ALTIN ÜYELİK Hakkında Bilgi


Geri Git   Excel Forum > EXCEL-Soruları > Excel'e Yeni Başlayanlar
Atatürk
Şifremi Unuttum

DUYURU SİSTEMİ / REKLAM PANOSU

Excel'e Yeni Başlayanlar Excel kullanmaya yeni başladıysanız sorularınızı buraya gönderebilirsiniz.
Dosya ekleyebilirsiniz

Özel Arama


Yanıtla
 
Paylaş Konu Araçları Görünüm Modları
Eski 01-08-2016, 15:47   #1
u.L.a.s
 
Giriş: 08/09/2008
Şehir: İstanbul
Mesaj: 533
Excel Vers. ve Dili:
2010 İngilizce
Varsayılan Outlooktan Excele mail konu başlıkları tarihleri gibi bilgileri satır satır dökme

Elimde aşağıdaki gibi bir kod düzeneği var.

Bu kod düzeneği Microsoft outlook ta bulunan mailleri excele aşağıdaki gibi belli başlıkları listeliyor.



Fakat bu kod düzeneği outlook ta tüm hepsini getiriyor.

Ben istiyorum ki Belli tarih aralığını getirsin. Örneğin geçen ay 01.07.2016 ile 31.07.2016 tarihleri arasındaki mailleri döksün istiyorum.

ne bilim 25.07.2016 ile 01.08.2016 tarihleri arasını döksün istiyorum yani ben tarih yazayım sadece o tarihlerdeki mailleri listelesin istiyorum.

Bilgi ve yardımlarınızı rica ederim



Kod: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
Option Explicit

Private lRow As Long, x As Date, oWS As Worksheet

Sub GetFromInbox()
    Const olFolderDrafts = 6
    Dim olApp As Object, olNs As Object
    Dim oRootFldr As Object
    Dim lCalcMode As Long

    Set olApp = CreateObject("Outlook.Application")
    Set olNs = olApp.GetNamespace("MAPI")
    Set oRootFldr = olNs.GetDefaultFolder(olFolderDrafts) '.Folders(InputBox("Maillerin bulunduğu klasörü giriniz", "BDD"))
    Set oWS = ActiveSheet

    x = Date
    lRow = 2
    lCalcMode = Application.Calculation
    Application.Calculation = xlCalculationManual
    'Application.ScreenUpdating = False
    GetFromFolder oRootFldr
   ' Application.ScreenUpdating = True
    Application.Calculation = lCalcMode

    Set oWS = Nothing
    Set oRootFldr = Nothing
    Set olNs = Nothing
    Set olApp = Nothing
End Sub

Private Sub GetFromFolder(oFldr As Object)
    Dim oItem As Object, oSubFldr As Object

    For Each oItem In oFldr.Items
    Range("g1").Value = lRow
        If TypeName(oItem) = "MailItem" Then
            With oItem
'               If .Subject = "Is Goremezlik Raporu" Then
                    oWS.Cells(lRow, 1).Value = .SenderName
                    oWS.Cells(lRow, 2).Value = .to
                    oWS.Cells(lRow, 3).Value = .cc
                    oWS.Cells(lRow, 4).Value = .Subject
                    oWS.Cells(lRow, 5).Value = .ReceivedTime
                    oWS.Cells(lRow, 6).Value = .body
                    lRow = lRow + 1
                   ' If lRow = 10 Then Exit Sub
'                End If
            End With
        End If
    Next

    ' Recurse all Subfolders
    For Each oSubFldr In oFldr.Folders
        GetFromFolder oSubFldr
    Next
End Sub
u.L.a.s Çevrimdışı   Alıntı Yaparak Cevapla
Eski 02-08-2016, 08:17   #2
hamitcan
Uzman
 
hamitcan kullanıcısının avatarı
 
Giriş: 01/07/2004
Mesaj: 7,052
Excel Vers. ve Dili:
Excel 2007 Türkçe
Varsayılan

Aşağıda kırmızı ile belirttiğim satırı ekleyin.
Kod: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
Option Explicit

Private lRow As Long, x As Date, oWS As Worksheet

Sub GetFromInbox()
    Const olFolderDrafts = 6
    Dim olApp As Object, olNs As Object
    Dim oRootFldr As Object
    Dim lCalcMode As Long

    Set olApp = CreateObject("Outlook.Application")
    Set olNs = olApp.GetNamespace("MAPI")
    Set oRootFldr = olNs.GetDefaultFolder(olFolderDrafts) '.Folders(InputBox("Maillerin bulunduğu klasörü giriniz", "BDD"))
    Set oWS = ActiveSheet

    x = Date
    lRow = 2
    lCalcMode = Application.Calculation
    Application.Calculation = xlCalculationManual
    'Application.ScreenUpdating = False
    GetFromFolder oRootFldr
   ' Application.ScreenUpdating = True
    Application.Calculation = lCalcMode

    Set oWS = Nothing
    Set oRootFldr = Nothing
    Set olNs = Nothing
    Set olApp = Nothing
End Sub

Private Sub GetFromFolder(oFldr As Object)
    Dim oItem As Object, oSubFldr As Object

    For Each oItem In oFldr.Items
    If lRow = 5 Then Exit Sub
    Range("g1").Value = lRow
        If TypeName(oItem) = "MailItem" Then
            With oItem
           
 If .receivedtime >= "25/05/2016" And .receivedtime <= "26/05/2016" Then ' Bu satırı ekledim.
'               If .Subject = "Is Goremezlik Raporu" Then
                    oWS.Cells(lRow, 1).Value = .SenderName
                    oWS.Cells(lRow, 2).Value = .to
                    oWS.Cells(lRow, 3).Value = .cc
                    oWS.Cells(lRow, 4).Value = .Subject
                    oWS.Cells(lRow, 5).Value = .receivedtime
'                    oWS.Cells(lRow, 6).Value = .body
                    lRow = lRow + 1
                   ' If lRow = 10 Then Exit Sub
                End If
'End If
            End With
        End If
    Next

    ' Recurse all Subfolders
    For Each oSubFldr In oFldr.Folders
        GetFromFolder oSubFldr
    Next
End Sub
__________________
Yolda Yürüme Kuralları







hamitcan Çevrimdışı   Alıntı Yaparak Cevapla
Eski 02-08-2016, 09:41   #3
u.L.a.s
 
Giriş: 08/09/2008
Şehir: İstanbul
Mesaj: 533
Excel Vers. ve Dili:
2010 İngilizce
Varsayılan

bu satırı ekledim fakat yine en eski mailden itibaren listeyi dökmeye başladı.
u.L.a.s Çevrimdışı   Alıntı Yaparak Cevapla
Eski 02-08-2016, 10:06   #4
hamitcan
Uzman
 
hamitcan kullanıcısının avatarı
 
Giriş: 01/07/2004
Mesaj: 7,052
Excel Vers. ve Dili:
Excel 2007 Türkçe
Varsayılan

Ben denedim, düzgün çalıştı.
__________________
Yolda Yürüme Kuralları







hamitcan Çevrimdışı   Alıntı Yaparak Cevapla
Eski 02-08-2016, 11:18   #5
u.L.a.s
 
Giriş: 08/09/2008
Şehir: İstanbul
Mesaj: 533
Excel Vers. ve Dili:
2010 İngilizce
Varsayılan

bu kodda belirttiğin gibi aşağıdaki şekilde kodu ekledim.
Kırmızı renklerle işaretledim. hatta bazı başlıklar gelmesin diyede ' işaretini koydum bana lazım olanları açık bıraktım.

Bu haliyle bile 2009 dan bu yana olan maillerimi sırasıyla dökmeye başladı.



Kod: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
Private Sub GetFromFolder(oFldr As Object)
    Dim oItem As Object, oSubFldr As Object

    For Each oItem In oFldr.Items
    Range("g1").Value = lRow
        If TypeName(oItem) = "MailItem" Then
 
            With oItem
                       If .receivedtime >= "01/07/2016" And .receivedtime <= "31/07/2016" Then
'               If .Subject = "Is Goremezlik Raporu" Then
                    'oWS.Cells(lRow, 1).Value = .SenderName
                    'oWS.Cells(lRow, 2).Value = .to
                    'oWS.Cells(lRow, 3).Value = .cc
                    oWS.Cells(lRow, 4).Value = .Subject
                    oWS.Cells(lRow, 5).Value = .receivedtime
                    'oWS.Cells(lRow, 6).Value = .body
                    lRow = lRow + 1
                   ' If lRow = 10 Then Exit Sub
'                End If
End If
            End With
        End If
    Next

    ' Recurse all Subfolders
    For Each oSubFldr In oFldr.Folders
        GetFromFolder oSubFldr
    Next
End Sub
u.L.a.s Çevrimdışı   Alıntı Yaparak Cevapla
Eski 02-08-2016, 12:28   #6
tahsinanarat
Altın Üye
 
Giriş: 14/03/2005
Şehir: İstanbul
Mesaj: 1,754
Excel Vers. ve Dili:
Ofis 2016 Türkçe
Varsayılan

Sn. hamitcan Bey bende denedim üç satır getiriyor, tarihleri değiştirerek denedim yine aynı satırları (üç satır) getiriyor. Bilgilerinize.
__________________
Kolay Gelsin Tahsin.
tahsinanarat Çevrimdışı   Alıntı Yaparak Cevapla
Eski 02-08-2016, 13:11   #7
mustilem23
Altın Üye
 
Giriş: 29/10/2010
Şehir: bursa
Mesaj: 280
Excel Vers. ve Dili:
office 2010
Varsayılan

hamitcan Bey merhaba umarım müsaitsiniz dir,

kodunuzu boş bir excelin vba penceresine ekledim çalışıyor fakat email içerisin de satır ve sütunlara bölünmüş hücreler var ise şöyle bir hata veriyor ,(type mismatch)

yeni konu açmak yerine olanları kullanmak istedim fakat bu hali ile işlerim hal olmuyor ,

talebim örnek verecek olur isek 02 08 2016 tarihin de bana gelen yada konu başlığını test olarak ilettiğim her email için bir excel oluşturup içeriğinde bulunan stok kodlarını tanımını ve adetini ayrı sutunda excele kaydettirebilmek mümkün müdür ? (her email için 1 excel)

Örnek email ve dosyam aşağıdaki gibidir.

http://s4.dosya.tc/server2/mapbvp/email_veri.rar.html

yardımlarınız için şimdi den çok teşekkürler...
mustilem23 Çevrimdışı   Alıntı Yaparak Cevapla
Eski 02-08-2016, 15:48   #8
hamitcan
Uzman
 
hamitcan kullanıcısının avatarı
 
Giriş: 01/07/2004
Mesaj: 7,052
Excel Vers. ve Dili:
Excel 2007 Türkçe
Varsayılan

Kodları düzenleme yaptıktan sonra tekrar gönderiyorum.

Kod: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
Option Explicit

Private lRow As Long, x As Date, oWS As Worksheet

Sub GetFromInbox()
    Const olFolderDrafts = 6
    Dim olApp As Object, olNs As Object
    Dim oRootFldr As Object
    Dim lCalcMode As Long

    Set olApp = CreateObject("Outlook.Application")
    Set olNs = olApp.GetNamespace("MAPI")
    Set oRootFldr = olNs.GetDefaultFolder(olFolderDrafts) '.Folders(InputBox("Maillerin bulunduğu klasörü giriniz", "BDD"))
    Set oWS = ActiveSheet

    x = Date
    lRow = 2
    lCalcMode = Application.Calculation
    Application.Calculation = xlCalculationManual
    'Application.ScreenUpdating = False
    GetFromFolder oRootFldr
   ' Application.ScreenUpdating = True
    Application.Calculation = lCalcMode

    Set oWS = Nothing
    Set oRootFldr = Nothing
    Set olNs = Nothing
    Set olApp = Nothing
End Sub

Private Sub GetFromFolder(oFldr As Object)
    Dim oItem As Object, oSubFldr As Object

    For Each oItem In oFldr.Items
'    If lRow = 5 Then Exit Sub
'    Range("g1").Value = lRow
        If TypeName(oItem) = "MailItem" Then
            With oItem
           
            If Format(.receivedtime, "00000") >= Format("02/07/2016", "00000") And Format(.receivedtime, "00000") <= Format("01/08/2016", "00000") Then
'               If .Subject = "Is Goremezlik Raporu" Then
                    oWS.Cells(lRow, 1).Value = .SenderName
                    oWS.Cells(lRow, 2).Value = .to
                    oWS.Cells(lRow, 3).Value = .cc
                    oWS.Cells(lRow, 4).Value = .Subject
                    oWS.Cells(lRow, 5).Value = .receivedtime
'                    oWS.Cells(lRow, 6).Value = .body
                    lRow = lRow + 1
                   ' If lRow = 10 Then Exit Sub
                End If
'End If
            End With
        End If
    Next

    ' Recurse all Subfolders
    For Each oSubFldr In oFldr.Folders
        GetFromFolder oSubFldr
    Next
End Sub
__________________
Yolda Yürüme Kuralları







hamitcan Çevrimdışı   Alıntı Yaparak Cevapla
Eski 02-08-2016, 18:15   #9
u.L.a.s
 
Giriş: 08/09/2008
Şehir: İstanbul
Mesaj: 533
Excel Vers. ve Dili:
2010 İngilizce
Varsayılan

makroyu çalıştırdım yarım saat önce hala veri dökmedi bana. sürekli kum saati dönüyr ama hiç bir veri getirmiyor.
u.L.a.s Çevrimdışı   Alıntı Yaparak Cevapla
Eski 03-08-2016, 07:55   #10
hamitcan
Uzman
 
hamitcan kullanıcısının avatarı
 
Giriş: 01/07/2004
Mesaj: 7,052
Excel Vers. ve Dili:
Excel 2007 Türkçe
Varsayılan

Aşağıdaki kod satırını silip deneyin. Eğer bu şekilde döküm alabiliryorsanız başka bir sorun var demektir.
Kod: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
  If Format(.receivedtime, "00000") >= Format("02/07/2016", "00000") And Format(.receivedtime, "00000") <= Format("01/08/2016", "00000") Then
__________________
Yolda Yürüme Kuralları







hamitcan Çevrimdışı   Alıntı Yaparak Cevapla
Yanıtla


Konu Araçları
Görünüm Modları

Gönderme Kuralları
You may not post new threads
You may not post replies
You may not post attachments
You may not edit your posts

BB code is Açık
SimgelerAçık
[IMG] kodu Açık
HTML kodu Kapalı


Saat 16:13


Bu forum Elit NET - www.elitnet.com.tr tarafından sunulmaktadır.

Excel Eğitimi - Mobil Uygulama - Çorlu - Çorlu Web Tasarım - Tarot Falı - invest in turkey - Lingerie - Dyeing Machine - Karton Bardak- Çorlu Özel Eğitim- Site Yönetimi- Led Aydınlatma- Pronet Tekirdağ- Çorlu Kamera- Pronet Edirne- Pronet Kırklareli- Pronet Çerkezköy- Pronet Çorlu- Pronet Lüleburgaz- Pronet Keşan- Çorlu Araç Takip- Çorlu Su Arıtma- Boru Profil- Gebze Emlak- Beylikdüzü Temizlik- İstanbul Burun Estetiği- Bakır Sülfat- Rampa- Rotary- Çorlu İnternet Sitesi- youngblood- Çorlu Palet- Çerkezköy Palet- Çorlu Prefabrik- Çorlu Sürücü Kursu- Çorlu Sandviç Panel- Şişli Avukat- Korona Test Kalemi- Çorlu Vinç- Çorlu Pimapen Tamiri-
Powered by vBulletin Version 3.7.2
Copyright ©2000 - 2017, Jelsoft Enterprises Ltd.
Advertisement System V2.6 By   Branden