Excel Forum

Excel Forum (http://www.excel.web.tr/index.php)
-   Makro-VBA (http://www.excel.web.tr/forumdisplay.php?f=48)
-   -   Outlook Gelen E-Posta ve Eklerinin Excele raporlaması (http://www.excel.web.tr/showthread.php?t=167985)

nkeles 08-11-2017 16:12

Outlook Gelen E-Posta ve Eklerinin Excele raporlaması
 
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.

asri 08-11-2017 21:00

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.

nkeles 09-11-2017 10:11

Merhaba,
Örnek yazışma maili ektedir. Ek kısmında e fatura yı görebilirsiniz. BM ile başlayan faturanın numarasıdır.

http://www.imgim.com/9765incis1939641.jpg

BedriA 09-11-2017 13:55

Alıntı:

asri tarafından gönderildi (Mesaj 916697)
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?

asri 09-11-2017 13:57

Alıntı:

BedriA tarafından gönderildi (Mesaj 916784)
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?

nkeles 09-11-2017 15:16

Alıntı:

nkeles tarafından gönderildi (Mesaj 916654)
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..

BedriA 09-11-2017 19:44

Alıntı:

asri tarafından gönderildi (Mesaj 916785)
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.

PLİNT 09-11-2017 21:56

Alıntı:

BedriA tarafından gönderildi (Mesaj 916830)
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:

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("bedrihoca@gmail.com").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


PLİNT 09-11-2017 22:01

Alıntı:

nkeles tarafından gönderildi (Mesaj 916795)
Yok mudur çözüm..

Merhaba
Fatura no her zaman mesaj ekindeki dosya adı içeriğinde oluyormu?

nkeles 10-11-2017 07:43

Alıntı:

PLİNT tarafından gönderildi (Mesaj 916844)
Merhaba
Fatura no her zaman mesaj ekindeki dosya adı içeriğinde oluyormu?

Tüm faturalar aynı formatta gelir ve tüm faturalarda paylaştığım şekilde Fatura no yer almaktadır.

asri 10-11-2017 11:47

Alıntı:

nkeles tarafından gönderildi (Mesaj 916654)
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/Ge...ntrol.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


BedriA 10-11-2017 11:49

Alıntı:

PLİNT tarafından gönderildi (Mesaj 916841)
Merhaba
Aşağıdaki gibi deneyebilirsiniz;
[/size]


Çok teşekkürler.

nkeles 10-11-2017 13:12

Alıntı:

asri tarafından gönderildi (Mesaj 916918)
Excel vba references de microsft outlook v.xx seçili olmalı.

http://s4.dosya.tc/server5/b6nmh4/Ge...ntrol.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.

asri 10-11-2017 13:51

Alıntı:

nkeles tarafından gönderildi (Mesaj 916931)
Ü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.

nkeles 10-11-2017 14:21

Aşağıdaki hatayı almaktayım..



http://www.imgim.com/6020incig1591534.jpg

asri 10-11-2017 14:24

Alıntı:

nkeles tarafından gönderildi (Mesaj 916952)
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ı.

nkeles 10-11-2017 14:47

Alıntı:

asri tarafından gönderildi (Mesaj 916953)
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.. :)


Saat 09:42

Powered by vBulletin Version 3.7.2
Copyright ©2000 - 2017, Jelsoft Enterprises Ltd.