Outlook Konu Alanından Bilgi Çekme

tirEdsOuL · 25 Ocak 2017

Arkadaşlar Merhaba;

Hergün düzenli olarak gelen maillerimden konu alanında bulunan bazı yerleri belirteceğim tarihten itibaren 3ncü satırdan başlayarak yazdırmak istiyorum.

C3'den itibaren tarih karakter uzunluğu sabit
D3'den itibaren sipariş no karakter uzunluğu sabit
E3'den itibaren paket karakter uzunluğu değişken

Sabit konu alanı : "POLAR: ARAÇ BİLDİRİMİ ALIM ONAYINIZI BEKLİYOR. - Bayi: Abcdef - Sipariş: 5658115919 - Paket: Select 548O - Son Tarih: 07.02.2017 01:00:00"

-----

Outlook'a gelen mailleri excele yazdırmak için bayramdede.com adresinden aşağıdaki gibi kod buldum ama bu kodda tarih aralığı olmadığı için tüm mailleri listeliyor.

Bu tarih problemi için de aynı kod üzerinden forumda u.L.a.s arkadaşımız bir konu açmış ama sonuca bağlanamamış.
Aşağıdaki koda tarih aralığı belirtebilirsek, sadece konu alanındaki istediğim alanları ilgili hücrelere yazdırmak kalacak.

Kod:

Option Explicit

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

Sub GetFromInbox()
    Const olFolderInbox = 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(olFolderInbox) '.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

Asri · 25 Ocak 2017

Gelen kutusundaki bu tarihler arasındaki maillerin konusunu getirir.
İstenen şekilde konuyu parçalara ayırır.

Kod:

Dim arrData() As Variant
Dim Cnt As Long
Dim baslatarih, tarih, bitirtarih, sontarih As Date

Sub Mail_al()
    Dim olApp As Object
    Dim olNS As Object
    Dim olFldr As Object
    
    sonsatir = Cells(Rows.Count, "C").End(3).Row
    If sonsatir = 2 Then sontarih = "01.01.2017 00:00:00" Else sontarih = Cells(sonsatir, 6)
    
    Set olApp = CreateObject("Outlook.Application")
    Set olNS = olApp.GetNamespace("MAPI")
    '5=olFolderSentMail, 6=olFolderInbox
    Set olFldr = olNS.GetDefaultFolder(6).Folders("Bildirilen Araçlar") 'aranacak klasör
    
    'baslatarih = DateValue(Cells(2, "N"))
    'bitirtarih = DateValue(Cells(2, "O"))
    
    Cnt = 0
    Call RecursiveFolders(olFldr)
    'Range("C3:F10000").ClearContents
    
    If Cnt <> 0 Then
       ActiveSheet.Range("C" & sonsatir + 1).Resize(UBound(arrData, 2), UBound(arrData, 1)).Value = WorksheetFunction.Transpose(arrData)
       ActiveSheet.Columns.AutoFit
    End If
    
  
End Sub

Sub RecursiveFolders(olFolder As Object)
    Dim olSubFolder As Object
    Dim olMail As Object

    For Each olMail In olFolder.Items
      If InStr(olMail.Subject, "POLAR: ARAÇ BİLDİRİMİ ALIM ONAYINIZI BEKLİYOR.") > 0 Then
        tarih = DateValue(Left(olMail.SentOn, 10))
            
        'If tarih >= baslatarih And tarih <= bitirtarih Then
         If olMail.SentOn > CDate(sontarih) Then
            
            Cnt = Cnt + 1
            ReDim Preserve arrData(1 To 4, 1 To Cnt)
            'arrData(1, Cnt) = olMail.SentOn
           
            veri = olMail.Subject
            If InStr(veri, "Tarih:") > 0 Then tarihsip = Mid(veri, InStr(veri, "Tarih:") + 7, 10)
            If InStr(veri, "Sipariş:") > 0 Then siparis = Mid(veri, InStr(veri, "Sipariş:") + 9, 10)
            If InStr(veri, "Paket:") > 0 And (InStrRev(veri, "- Son") > InStr(veri, "Paket:")) Then paket = Mid(veri, InStr(veri, "Paket:") + 7, InStr(InStr(veri, "Paket:"), veri, "- Son") - InStr(veri, "Paket:") - 8)
            
            'arrData(2, Cnt) = olMail.Subject
            arrData(1, Cnt) = tarihsip
            arrData(2, Cnt) = siparis
            arrData(3, Cnt) = paket
            arrData(4, Cnt) = olMail.SentOn
        End If
      End If
    Next
    
   ' For Each olSubFolder In olFolder.Folders
   '     Call RecursiveFolders(olSubFolder)
   ' Next olSubFolder
    
End Sub

tirEdsOuL · 26 Ocak 2017

Sn. asri ilginiz için çok teşekkürler, bence kod alıntılıktan çıkmış baya bir emek harcamışsınız üzerinde..
Kodu bir modüle yapıştırdım, çalıştırdığımda ise "Invalid procedure call or argument" hatası verdi. ilgili hata satırı aşağıdadır.

Kod:

tarih = DateValue(Mid(olMail.SentOn, 1, InStr(olMail.SentOn, " ") - 1))

Asri · 26 Ocak 2017

tirEdsOuL' Alıntı:
Sn. asri ilginiz için çok teşekkürler, bence kod alıntılıktan çıkmış baya bir emek harcamışsınız üzerinde..
Kodu bir modüle yapıştırdım, çalıştırdığımda ise "Invalid procedure call or argument" hatası verdi. ilgili hata satırı aşağıdadır.

Kod:

tarih = DateValue(Mid(olMail.SentOn, 1, InStr(olMail.SentOn, " ") - 1))

Programı o aşamaya gelmeden durdurup olMail.SentOn in değerine bakar mısınız?
Tarihten sonra boşluk ve saat var mı?

Kodu aşağıdaki şekilde değiştirin ancak bu şekilde değiştirdiğinizde istediğiniz sonucu alamayabilir siniz.
Bende olMail.SentOn formatı farklı geliyor. 25.01.2017 16:32:00 gibi bir değer olması gerekiyor.

Kod:

        If InStr(olMail.SentOn, " ") > 0 Then
            tarih = DateValue(Mid(olMail.SentOn, 1, InStr(olMail.SentOn, " ") - 1))
        Else
          tarih = olMail.SentOn
        End If

tirEdsOuL · 26 Ocak 2017

asri' Alıntı:
Programı o aşamaya gelmeden durdurup olMail.SentOn in değerine bakar mısınız?
Tarihten sonra boşluk ve saat var mı?

Kodu aşağıdaki şekilde değiştirin ancak bu şekilde değiştirdiğinizde istediğiniz sonucu alamayabilir siniz.
Bende olMail.SentOn formatı farklı geliyor. 25.01.2017 16:32:00 gibi bir değer olması gerekiyor.

Kod:

If InStr(olMail.SentOn, " ") > 0 Then tarih = DateValue(Mid(olMail.SentOn, 1, InStr(olMail.SentOn, " ") - 1)) Else tarih = olMail.SentOn End If

Tarihten sonra dediğiniz gibi boşluk ve saat var, yeni vermiş olduğunuz kodu da aşağıdaki alana ekledim, bu sefer de "Object doesn't support this property or method" hatası verdi, ilgili satır ise "If InStr(olMail.SentOn, " ") > 0 Then"

Kod:

Sub RecursiveFolders(olFolder As Object)
    Dim olSubFolder As Object
    Dim olMail As Object

    For Each olMail In olFolder.Items
        [COLOR="Red"]If InStr(olMail.SentOn, " ") > 0 Then
           tarih = DateValue(Mid(olMail.SentOn, 1, InStr(olMail.SentOn, " ") - 1))
        Else
          tarih = olMail.SentOn
        End If[/COLOR]
        If tarih >= baslatarih And tarih <= bitirtarih Then
            Cnt = Cnt + 1
            ReDim Preserve arrData(1 To 5, 1 To Cnt)
            arrData(1, Cnt) = olMail.SentOn
           
            veri = olMail.Subject
            If InStr(veri, "Tarih:") > 0 Then tarih = Mid(veri, InStr(veri, "Tarih:") + 7, 10)
            If InStr(veri, "Sipariş:") > 0 Then siparis = Mid(veri, InStr(veri, "Sipariş:") + 9, 10)
            If InStr(veri, "Paket:") > 0 And (InStrRev(veri, "-") > InStr(veri, "Paket:")) Then paket = Mid(veri, InStr(veri, "Paket:") + 7, InStr(InStr(veri, "Paket:"), veri, "-") - InStr(veri, "Paket:") - 8)
            
            arrData(2, Cnt) = olMail.Subject
            arrData(3, Cnt) = tarih
            arrData(4, Cnt) = siparis
            arrData(5, Cnt) = paket
        End If
    Next
    
    'For Each olSubFolder In olFolder.Folders
    '    Call RecursiveFolders(olSubFolder)
    'Next olSubFolder
    
End Sub

Asri · 26 Ocak 2017

tirEdsOuL' Alıntı:
Tarihten sonra dediğiniz gibi boşluk ve saat var, yeni vermiş olduğunuz kodu da aşağıdaki alana ekledim, bu sefer de "Object doesn't support this property or method" hatası verdi, ilgili satır ise "If InStr(olMail.SentOn, " ") > 0 Then"

olMail.SentOn i Debug "ADD Watch" ye ekleyip hata veren satırda durdurup içeriğini yazar mısınız?

tirEdsOuL · 26 Ocak 2017

asri' Alıntı:
olMail.SentOn i Debug "ADD Watch" ye ekleyip hata veren satırda durdurup içeriğini yazar mısınız?

olMail.SentOn olarak ADD Watch'a eklediğimde aşağıdaki gibi çıkıyor.

Sadece olMail'i ADD Watch'a eklersem de aşağıdaki gibi çok satırlı bir alan çıkıyor ama burada hata veren satırı bulamıyorum.

Asri · 26 Ocak 2017

Bu şekilde deneyiniz.

Kod:

tarih = DateValue(Mid(olMail.SentOn, 2, InStr(olMail.SentOn, " ") - 1))

tirEdsOuL · 26 Ocak 2017

asri' Alıntı:
Bu şekilde deneyiniz.

Kod:

tarih = DateValue(Mid(olMail.SentOn, 2, InStr(olMail.SentOn, " ") - 1))

Bu sefer de "Type mismatch" hatası vermekte, Debug ise aşağıdaki gibidir.

Asri · 26 Ocak 2017

tirEdsOuL' Alıntı:
Bu sefer de "Type mismatch" hatası vermekte, Debug ise aşağıdaki gibidir.

İf li bölümü silin bunu deneyin.

Bende hiç bir sorun çıkarmıyor.

Kod:

tarih = DateValue(Left(olMail.SentOn, 10))

assenucler · 26 Ocak 2017

Bilgi ricam

Sayın tirEdsOuL,

Yukarıdaki iletilerinize eklediğiniz normal ekran resimlerini "hangi yazılım" ile ekliyorsunuz. Benim siteye eklediklerim çok küçük çıkıyor ve üstatlar büyütün diyorlar.

Bilgi verebilir misiniz?

Teşekkürler.

tirEdsOuL · 26 Ocak 2017

Değişen alan aşağıdaki gibidir ama yine çalışmadı, Sn. asri mümkünse sizde çalışan exceli paylaşabilir misiniz?

Bir de hata ile aklıma şöyle birşey geldi, kodunuz öncelik olarak aşağıdaki mail konusundaki koyu ile belirttiğim alan gibi, bir öncelik sorgulaması yapmıyor sanırım.

"POLAR: ARAÇ BİLDİRİMİ ALIM ONAYINIZI BEKLİYOR. - Bayi: Abcdef - Sipariş: 5658115919 - Paket: Select 548O - Son Tarih: 07.02.2017 01:00:00"

Yani "POLAR: ARAÇ BİLDİRİMİ ALIM ONAYINIZI BEKLİYOR." ile başlayan maillerde bu kodu çalıştır gibi.

Demek istediğim kodunuz çalışıyor ve ilk sorguladığı mailde bu kadar karakter yoksa ya da konu alanı boşsa hata veriyor olabilir mi ?

Kod:

Sub RecursiveFolders(olFolder As Object)
    Dim olSubFolder As Object
    Dim olMail As Object

    For Each olMail In olFolder.Items
    
        [COLOR="Red"]tarih = DateValue(Left(olMail.SentOn, 10))[/COLOR]
        
        If tarih >= baslatarih And tarih <= bitirtarih Then
            Cnt = Cnt + 1
            ReDim Preserve arrData(1 To 5, 1 To Cnt)
            arrData(1, Cnt) = olMail.SentOn

tirEdsOuL · 26 Ocak 2017

assenucler' Alıntı:
Sayın tirEdsOuL,

Yukarıdaki iletilerinize eklediğiniz normal ekran resimlerini "hangi yazılım" ile ekliyorsunuz. Benim siteye eklediklerim çok küçük çıkıyor ve üstatlar büyütün diyorlar.

Bilgi verebilir misiniz?

Teşekkürler.

Windows'un kendi "Ekran Alıntısı Aracı" ile ilgili alanı seçip kaydediyorum. Sonrasında herhangi bir resim yükleme sitesinden upload edip, mesaj yazılan alandan resim ekle menüsü ile resmi paylaşıyorum.

Asri · 26 Ocak 2017

tirEdsOuL' Alıntı:
Demek istediğim kodunuz çalışıyor ve ilk sorguladığı mailde bu kadar karakter yoksa ya da konu alanı boşsa hata veriyor olabilir mi ?

Kod, konusu POLAR: ile başlayanlar için düzenlendi.

Sorun konu değil, mailin geldiği tarihi okumak ile ilgili bir sorun var.
Benim excel imde özel birşey yok, sadece size göndermiş olduğum kod var.

tirEdsOuL · 26 Ocak 2017

Sn. asri güncellediğiniz 2nci mesajınızdaki kodu tekrar aldığımda, bu sefer farklı bir yerde hata verdi. Hata mesajı "Invalid procedure call or argument"

Hata satırı

Kod:

ActiveSheet.Range("A3").Resize(UBound(arrData, 2), UBound(arrData, 1)).Value = WorksheetFunction.Transpose(arrData)

Asri · 26 Ocak 2017

Kod güncellendi.

tirEdsOuL · 26 Ocak 2017

Sn. asri bey, ilgi ve yardımlarınızdan dolayı çok çok teşekkür ederim. Sayenizde büyük bir iş yükünden kurtuldum.
Bu konudan bağımsız ufak bir sıkıntı yaşıyorum. Bu tablomda A sütununa önceden 2 yazdığım şimdi Banka yazdığım satırları Sn. Emir Hüseyin Çoban hocamızın hazırlamış olduğu aşağıdaki kod ile mail olarak gönderiyorum. Yalnız bizim yaptığımız değişiklikten sonra, maile yapıştırılan satırlar excelde göründüğü gibi gelmiyor, sütun ve satır genişlikleri baya bi genişlemiş olarak geliyor. Bunu nasıl düzeltebiliriz?

Kod:

Sub kod()
    Dim S1 As Worksheet: Set S1 = Sheets("mail için")
    Dim OutApp As Object
    Dim OutMail As Object
    sayfalar = Array("", "Araç")
    Dim i As Byte
    Dim sonsat As Integer
    
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    
    S1.Visible = True: S1.Select
    S1.Cells.Clear
    
    S1.Range("B1") = "Aşağıda detayları verilen araçların alınmasını rica ederim."
    S1.Range("B2") = " "
    
    
    For i = 1 To 3
        With Sheets(sayfalar(i))
            On Error Resume Next
            
            If Not .AutoFilterMode Then
                .Range("A1").AutoFilter
            Else
                .ShowAllData
            End If
            
            .Range("A1").AutoFilter Field:=1, Criteria1:="Banka"
            .AutoFilter.Range.Copy
            sonsat = S1.Cells(Rows.Count, "B").End(3).Row + 1
            S1.Cells(sonsat, "A").PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
            SkipBlanks:=False, Transpose:=False
            S1.Paste
            Application.CutCopyMode = False
            
            If sonsat <> 3 Then
                S1.Rows(sonsat).Delete Shift:=xlUp
            End If
        End With
    Next i
    
    For i = 1 To 3
        With Sheets(sayfalar(i))
            If Not .AutoFilterMode Then
                .Range("A1").AutoFilter
            Else
                .ShowAllData
            End If
        End With
    Next i
    
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
      
    sonsat = S1.Cells(Rows.Count, "B").End(3).Row + 1
    
    S1.Range("B1:H" & sonsat + 3).Copy
    With OutMail
        .To = "x@x.com.tr"
        .Subject = "Araç Alımları Hk."
        .Display
        DoEvents
        SendKeys "^v", True
    End With
    
    S1.Visible = False
    
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
    
    Set OutMail = Nothing
    Set OutApp = Nothing
    
    Application.SendKeys ("{NUMLOCK}")
    
End Sub

Outlook Konu Alanından Bilgi Çekme

Ekli dosyalar