Outlook Gelen E-Posta ve Eklerinin Excele raporlaması

Katılım
13 Temmuz 2011
Mesajlar
29
Excel Vers. ve Dili
visual basic
Merhaba,
E fatura mükellefi bir firmada çalışıyorum. E faturalar entegratör firma tarafından ek olarak mail yoluyla iletiliyor. Bu faturalar hakkında yazışmalar yapıyoruz. Şirket içinde fatura maillerine, Onaylanmıştır, Red Edilmiştir, gibi dönüşler yapılıyor.
İsteğimiz örneğin İdari İşler den hangi e fatura için (efatura ek dosyasında efaturanın numarası yazılı) ne yazılmış excel e aktarılmasını istiyoruz.

Gönderen Fatura No Mail İçeriği Şeklinde Excel e rapor yapabilir miyiz.
 
Katılım
24 Nisan 2005
Mesajlar
3,652
Excel Vers. ve Dili
Office 2016 EN 64 Bit
Yardımcı olacak arkadaşların yardım edebilmesi için örnek mailler ihtiyaç var.
Belki mail görüntüleri de işe yarayabilir.
 
Katılım
13 Temmuz 2011
Mesajlar
29
Excel Vers. ve Dili
visual basic
Merhaba,
Örnek yazışma maili ektedir. Ek kısmında e fatura yı görebilirsiniz. BM ile başlayan faturanın numarasıdır.

 
Katılım
3 Haziran 2017
Mesajlar
797
Excel Vers. ve Dili
2007, 32
Yardımcı olacak arkadaşların yardım edebilmesi için örnek mailler ihtiyaç var.
Belki mail görüntüleri de işe yarayabilir.
Asri Hocam,

Bana da Outlook Gelen Kutusu'nu temizleyecek bir kod lazım.
Arşivinizde var mıdır acaba?
 
Katılım
24 Nisan 2005
Mesajlar
3,652
Excel Vers. ve Dili
Office 2016 EN 64 Bit
Asri Hocam,

Bana da Outlook Gelen Kutusu'nu temizleyecek bir kod lazım.
Arşivinizde var mıdır acaba?
Temizlemek derken? Biraz daha detay verebilir misiniz?
Gelen kutusundakileri silmek için ctrl+a ve del yeterli olur.

Farklı bir durum ise nedir?
 
Katılım
13 Temmuz 2011
Mesajlar
29
Excel Vers. ve Dili
visual basic
Merhaba,
E fatura mükellefi bir firmada çalışıyorum. E faturalar entegratör firma tarafından ek olarak mail yoluyla iletiliyor. Bu faturalar hakkında yazışmalar yapıyoruz. Şirket içinde fatura maillerine, Onaylanmıştır, Red Edilmiştir, gibi dönüşler yapılıyor.
İsteğimiz örneğin İdari İşler den hangi e fatura için (efatura ek dosyasında efaturanın numarası yazılı) ne yazılmış excel e aktarılmasını istiyoruz.

Gönderen Fatura No Mail İçeriği Şeklinde Excel e rapor yapabilir miyiz.
Yok mudur çözüm..
 
Katılım
3 Haziran 2017
Mesajlar
797
Excel Vers. ve Dili
2007, 32
Temizlemek derken? Biraz daha detay verebilir misiniz?
Gelen kutusundakileri silmek için ctrl+a ve del yeterli olur.

Farklı bir durum ise nedir?

Makro ile; gelen mesajları silmek istiyorum, outlook ile değil, ara yüz olarak kullandığım excel dosyasından.
 
Katılım
31 Aralık 2014
Mesajlar
1,845
Excel Vers. ve Dili
Excel 2010
Makro ile; gelen mesajları silmek istiyorum, outlook ile değil, ara yüz olarak kullandığım excel dosyasından.
Merhaba
Aşağıdaki gibi deneyebilirsiniz;
Kod:
[SIZE="2"]Private Sub CommandButton1_Click()

Dim a As Object, b As Object, c As Object
Dim msg
Set a = CreateObject("Outlook.Application")
Set b = a.GetNamespace("MAPI")
 Set c = a.GetNamespace("MAPI").Folders("[COLOR="Blue"]bedrihoca@gmail.com[/COLOR]").Folders(2)
  For i = c.items.Count To 1 Step -1
sor = MsgBox(c.items(i).SenderEmailAddress & " Adresinden gelen mail silinsinmi?", vbYesNo)
If sor = vbYes Then c.items(i).Delete
Next
    
End Sub [/SIZE]
 
Katılım
24 Nisan 2005
Mesajlar
3,652
Excel Vers. ve Dili
Office 2016 EN 64 Bit
Merhaba,
E fatura mükellefi bir firmada çalışıyorum. E faturalar entegratör firma tarafından ek olarak mail yoluyla iletiliyor. Bu faturalar hakkında yazışmalar yapıyoruz. Şirket içinde fatura maillerine, Onaylanmıştır, Red Edilmiştir, gibi dönüşler yapılıyor.
İsteğimiz örneğin İdari İşler den hangi e fatura için (efatura ek dosyasında efaturanın numarası yazılı) ne yazılmış excel e aktarılmasını istiyoruz.

Gönderen Fatura No Mail İçeriği Şeklinde Excel e rapor yapabilir miyiz.
Excel vba references de microsoft outlook v.xx seçili olmalı.

http://s4.dosya.tc/server5/b6nmh4/Gelen_Fatura_Kontrol.zip.html



Kod:
Dim lrow As Long
Dim ows As Worksheet
Dim bilgi As String

Sub GetFromInbox()
    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 = olApp.Session.PickFolder
    Set oRootFldr = olNs.GetDefaultFolder(6)
    Set ows = ActiveSheet
    sonsatir = Cells(Rows.Count, "B").End(3).Row
    If sonsatir = 1 Then sonsatir = 2
    Range("A2:E" & sonsatir).ClearContents
    
    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 TypeName(oItem) = "MailItem" Then
            With oItem
               If InStr(.Subject, "Gelen Fatura") > 0 Then
                  Faturano = ""
                  For j = 1 To .Attachments.Count
                      dosya = .Attachments.Item(j).Filename
                      dosya = Mid(dosya, InStrRev(dosya, "-") + 1, Len(dosya))
                      uzanti = Mid(dosya, InStrRev(dosya, "."), Len(dosya))
                      dosya = Mid(dosya, 1, InStrRev(dosya, ".") - 1)
                      If uzanti = ".html" And Left(dosya, 2) = "BM" Then
                        Faturano = dosya
                        Exit For
                      End If
                  Next j

                  ows.Cells(lrow, 1).Value = fnGetSMTPAddress(.SenderEmailaddress)
                  ows.Cells(lrow, 2).Value = .Subject
                  ows.Cells(lrow, 3).Value = .ReceivedTime
                  ows.Cells(lrow, 4).Value = Faturano
                  bilgi = Replace(.body, Chr(13), "")
                  bilgi = Replace(.body, Chr(10), "")
                  bilgi = Replace(.body, "  ", " ")
                  ows.Cells(lrow, 5).Value = cleanString(bilgi)
                  lrow = lrow + 1
                
                End If
            End With
        End If
    Next

    ' Recurse all Subfolders
    'For Each oSubFldr In oFldr.Folders
    '    GetFromFolder oSubFldr
    'Next
End Sub


Function cleanString(text As String) As String
    Dim output As String
    Dim c As String
    For i = 1 To Len(text)
        c = Mid(text, i, 1) 'Select the character at the i position
        If Asc(c) > 64 Then
            output = output & c 'add the character to your output.
        Else
            output = output & " " 'add the replacement character (space) to your output
        End If
    Next
    cleanString = output
End Function

Public Function fnGetSMTPAddress(ExchangeMailAddress As String) As String
Dim objOutlook As Outlook.Application
Dim objMailItem As Outlook.MailItem

Set objOutlook = New Outlook.Application
Set objMailItem = objOutlook.CreateItem(0)
objMailItem.To = ExchangeMailAddress
objMailItem.Recipients.ResolveAll
On Error Resume Next
If objMailItem.Recipients.Item(1).Resolved Then
fnGetSMTPAddress = objMailItem.Recipients.Item(1).AddressEntry.GetExchangeUser.PrimarySmtpAddress
If Err.Number <> 0 Then fnGetSMTPAddress = ExchangeMailAddress
Else
fnGetSMTPAddress = ExchangeMailAddress
End If
Set objMailItem = Nothing
Set objOutlook = Nothing

End Function
 
Son düzenleme:
Katılım
13 Temmuz 2011
Mesajlar
29
Excel Vers. ve Dili
visual basic
Excel vba references de microsft outlook v.xx seçili olmalı.

http://s4.dosya.tc/server5/b6nmh4/Gelen_Fatura_Kontrol.zip.html



Kod:
Dim lrow As Long
Dim ows As Worksheet
Dim bilgi As String

Sub GetFromInbox()
    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 = olApp.Session.PickFolder
    Set oRootFldr = olNs.GetDefaultFolder(6)
    Set ows = ActiveSheet
    sonsatir = Cells(Rows.Count, "B").End(3).Row
    If sonsatir = 1 Then sonsatir = 2
    Range("A2:E" & sonsatir).ClearContents
    
    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 TypeName(oItem) = "MailItem" Then
            With oItem
               If InStr(.Subject, "Gelen Fatura") > 0 Then
                  Faturano = ""
                  For j = 1 To .Attachments.Count
                      dosya = .Attachments.Item(j).Filename
                      dosya = Mid(dosya, InStrRev(dosya, "-") + 1, Len(dosya))
                      uzanti = Mid(dosya, InStrRev(dosya, "."), Len(dosya))
                      dosya = Mid(dosya, 1, InStrRev(dosya, ".") - 1)
                      If uzanti = ".html" And Left(dosya, 2) = "BM" Then
                        Faturano = dosya
                        Exit For
                      End If
                  Next j

                  ows.Cells(lrow, 1).Value = fnGetSMTPAddress(.SenderEmailaddress)
                  ows.Cells(lrow, 2).Value = .Subject
                  ows.Cells(lrow, 3).Value = .ReceivedTime
                  ows.Cells(lrow, 4).Value = Faturano
                  bilgi = Replace(.body, Chr(13), "")
                  bilgi = Replace(.body, Chr(10), "")
                  bilgi = Replace(.body, "  ", " ")
                  ows.Cells(lrow, 5).Value = cleanString(bilgi)
                  lrow = lrow + 1
                
                End If
            End With
        End If
    Next

    ' Recurse all Subfolders
    'For Each oSubFldr In oFldr.Folders
    '    GetFromFolder oSubFldr
    'Next
End Sub


Function cleanString(text As String) As String
    Dim output As String
    Dim c As String
    For i = 1 To Len(text)
        c = Mid(text, i, 1) 'Select the character at the i position
        If Asc(c) > 64 Then
            output = output & c 'add the character to your output.
        Else
            output = output & " " 'add the replacement character (space) to your output
        End If
    Next
    cleanString = output
End Function

Public Function fnGetSMTPAddress(ExchangeMailAddress As String) As String
Dim objOutlook As Outlook.Application
Dim objMailItem As Outlook.MailItem

Set objOutlook = New Outlook.Application
Set objMailItem = objOutlook.CreateItem(0)
objMailItem.To = ExchangeMailAddress
objMailItem.Recipients.ResolveAll
On Error Resume Next
If objMailItem.Recipients.Item(1).Resolved Then
fnGetSMTPAddress = objMailItem.Recipients.Item(1).AddressEntry.GetExchangeUser.PrimarySmtpAddress
If Err.Number <> 0 Then fnGetSMTPAddress = ExchangeMailAddress
Else
fnGetSMTPAddress = ExchangeMailAddress
End If
Set objMailItem = Nothing
Set objOutlook = Nothing

End Function

Üstad link çalışmıyor.. Ayrıca kurulum konusunda desteğe ihtiyacım var.
 
Katılım
24 Nisan 2005
Mesajlar
3,652
Excel Vers. ve Dili
Office 2016 EN 64 Bit
Üstad link çalışmıyor.. Ayrıca kurulum konusunda desteğe ihtiyacım var.
Link çalışıyor, 3 indirim olmuş.
Çalışmıyor ise firmanız engellemiş olabilir. Bilgi işlemden destek alınız.

Kurulum konusunda özel birşey yok, outlook açık olacak, excel dosyasını çalıştırıp butona basacaksınız.
 
Katılım
24 Nisan 2005
Mesajlar
3,652
Excel Vers. ve Dili
Office 2016 EN 64 Bit
Aşağıdaki hatayı almaktayım..
Dosyayı indirip mi denediniz? Kodu kopyala yapıştırıp yapıp mı denediniz?

Eğer kopyapa yapıştır yaptıysanız. Exce VBA bölümünde tools references de Microsoft outlook ... seçili olmalı.
 
Katılım
13 Temmuz 2011
Mesajlar
29
Excel Vers. ve Dili
visual basic
Dosyayı indirip mi denediniz? Kodu kopyala yapıştırıp yapıp mı denediniz?

Eğer kopyapa yapıştır yaptıysanız. Exce VBA bölümünde tools references de Microsoft outlook ... seçili olmalı.
Sanıyorum çalıştı çünkü excel kilitlendi.. :)
 

hamitcan

Uzman
Uzman
Katılım
1 Temmuz 2004
Mesajlar
7,678
Excel Vers. ve Dili
Excel 2019 Türkçe
Tarih ile ilgili bir örnek hazırladım. Diğerlerini buna bakarak yapabilirsiniz. Outlook referansını eklemeyi unutmayın.
Kod:
Sub List_Email_Info()
Dim xlApp As Excel.Application
Dim xlWB As Excel.Workbook
Dim i As Long ' Row tracker
Dim arrHeader As Variant

Dim olNS As Namespace
Dim olInboxFolder As MAPIFolder
Dim olItems As Items
Dim olMailItem As MailItem

arrHeader = Array("Date Created", "Subject", "Sender's Name", "Unread")

Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
Set xlWB = xlApp.Workbooks.Add

Set olNS = GetNamespace("MAPI")
Set olInboxFolder = olNS.GetDefaultFolder(olFolderInbox)
Set olItems = olInboxFolder.Items

i = 1
Tarih = Format("01/04/2020", "00000")

On Error Resume Next

xlWB.Worksheets(1).Range("A1").Resize(1, UBound(arrHeader) + 1).Value = arrHeader

For Each olMailItem In olItems
If Format(olItems(i).CreationTime, "00000") <= Tarih Then
    xlWB.Worksheets(1).Cells(i + 1, "A").Value = olItems(i).CreationTime
    xlWB.Worksheets(1).Cells(i + 1, "B").Value = olItems(i).Subject
    xlWB.Worksheets(1).Cells(i + 1, "C").Value = olItems(i).SenderName
    xlWB.Worksheets(1).Cells(i + 1, "D").Value = olItems(i).UnRead
    
    i = i + 1
 End If
Next olMailItem

xlWB.Worksheets(1).Cells.EntireColumn.AutoFit

MsgBox "Export complete.", vbInformation

Set xlWB = Nothing
Set xlApp = Nothing

Set olItems = Nothing
Set olInboxFolder = Nothing
Set olNS = Nothing

End Sub
 
Üst