• DİKKAT

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

Outlooktan Excele mail konu başlıkları tarihleri gibi bilgileri satır satır dökme

U

u.L.a.s

Katılım
8 Eylül 2008
Mesajlar
950
Excel Vers. ve Dili
2016 İngilizce
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.

AJBlW0.png


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: 
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
 
Aşağıda kırmızı ile belirttiğim satırı ekleyin.
Kod: 
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
           
 [COLOR=RED]If .receivedtime >= "25/05/2016" And .receivedtime <= "26/05/2016" Then[/COLOR] ' 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
 
bu satırı ekledim fakat yine en eski mailden itibaren listeyi dökmeye başladı.
 
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: 
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
                       [COLOR="Red"]If .receivedtime >= "01/07/2016" And .receivedtime <= "31/07/2016" Then[/COLOR]
'               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
[COLOR="Red"]End If[/COLOR]
            End With
        End If
    Next

    ' Recurse all Subfolders
    For Each oSubFldr In oFldr.Folders
        GetFromFolder oSubFldr
    Next
End Sub
 
Sn. hamitcan Bey bende denedim üç satır getiriyor, tarihleri değiştirerek denedim yine aynı satırları (üç satır) getiriyor. Bilgilerinize.
 
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...
 
Kodları düzenleme yaptıktan sonra tekrar gönderiyorum.

Kod: 
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
 
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.
 
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: 
  If Format(.receivedtime, "00000") >= Format("02/07/2016", "00000") And Format(.receivedtime, "00000") <= Format("01/08/2016", "00000") Then
 
Hamit Bey ,

8 nolu mesajınızdaki kodlar çalışıyor ,2 tarih aralığındaki gelen tüm emaillerin konu başlıklarını tarihlerini ve gelen gönderenleri sutun olarak listeliyor,excel de,


7 nolu mesajımdaki konu hakkında yardımcı olabilmeniz mümkün müdür ?
 
mustilem23' Alıntı:
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...
Genişletmek için tıkla ...
Tam tersini yapsanız daha kolay olmaz mı ? Yani Excel'den mail atmayı neden denemiyor sunuz ?
 
Müşteriden gelen emaili önce planlama bölümüne iletiliyor sonra cevap bana gelip teklif e dönüştüğü için böyle bir durum söz konusu ,tüm konuları aynı email de takip etmek için.

onun için email içerisin deki sadece kodlar tanımlar ve adetleri excele almak istiyorum bu bağlamda yardımcı olabilirmisiniz çok makbule geçecek ,


email içersinden export ederek denedim çok vakit kaybı + sutunları tek bir hücrede topluyor .
 
Bahsettiğiniz konuyu mail body üzerinden yapmak zor, en azından benim için. Bana kalırsa Excel'e atıp ayrıştırmak daha kolay.
 
hamitcan' Alıntı:
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: 
  If Format(.receivedtime, "00000") >= Format("02/07/2016", "00000") And Format(.receivedtime, "00000") <= Format("01/08/2016", "00000") Then
Genişletmek için tıkla ...

Zaten belli tarih aralığındaki mail sonuçlarını dökmek için sadece bu kodu ekstradan yazmıştınız. bu kod olmadan ilk haliyle evet çalışıyor ama en eski mailden itibaren dökmeye başlıyor.

ve inboxımda 175000 e yakın mal var. bu kadar maili dökmek bi hayli zaman istiyor.
 
hamitcan üstadım çok teşekkürler, kod benim de işime yaradı. Acaba gönderenin adı değil de mail adresini indirmek için kodu nasıl değiştirmek gerekir ? yani şu satır :

oWS.Cells(lRow, 1).Value = .SenderName
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst