Outlook daki Undeliverable Mesajlarını Excel e alma!

[unsal99]

Merhabalar;

Ben Outlook 'a dusen Undeliverable mesajlarini makro ile excel e almak istiyorum. Fakat bir turlu basaramadim.

Bu konuda bana yardimci olursaniz cok sevinirim.

Cevaplarinizi bekleyecegim.

Saygilar;
unsal99
:yardim:

 

[mancubus]

excel değil ama outlook VBA üzerinden çalışan aşağıdaki gibi bir kod buldum.

inbox altında oluşturulan "undelivered" isimli klasörde toplanan iletilemeyen mesajlardaki mail adreslerini daha önceden oluşturulmuş excel dosyasına kopyalıyor.

kırmızı font ile not düştüğüm yerdeki klasör ve dosya ismini kendi klasör ve dosya ismimize değiştirmek yeterli.

ben 2 mesaj üzerinden denedim çalıştı.

Option Explicit

Sub badAddress()
'http://www.vbaexpress.com/forum/showthread.php?t=33363

Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim olFolder As Outlook.MAPIFolder
Dim Item As MailItem
Dim regEx As Object
Dim olMatches As Object
Dim strBody As String
Dim bcount As String
Dim badAddresses As Variant
Dim i As Long
Dim xlApp As Object 'Excel.Application
Dim xlwkbk As Object 'Excel.Workbook
Dim xlwksht As Object 'Excel.Worksheet
Dim xlRng As Object 'Excel.Range

Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set olFolder = olNS.GetDefaultFolder(olFolderInbox).Folders("Undelivered")

Set regEx = CreateObject("VBScript.RegExp")
'define regular expression
regEx.Pattern = "\b[A-Z0-9._%-]+@[A-Z0-9.-]+\.[A-Z]{2,4}\b"
regEx.IgnoreCase = True
regEx.MultiLine = True
 
' set up size of variant
bcount = olFolder.Items.Count
ReDim badAddresses(1 To bcount) As String
 
' initialize variant position counter
i = 0
 
' parse each message in the folder holding the bounced emails
For Each Item In olFolder.Items
    i = i + 1
    strBody = olFolder.Items(i).Body
    Set olMatches = regEx.Execute(strBody)
    If olMatches.Count >= 1 Then
        badAddresses(i) = olMatches(0)
        Item.UnRead = False
    End If
Next Item
 
 ' write everything to Excel
Set xlApp = GetExcelApp

If xlApp Is Nothing Then GoTo ExitProc

If Not IsFileOpen("C:\Documents\Undelivered.xlsx") Then [COLOR="Red"]'istenilen klasör ve dosya ismine uyarlanacak[/COLOR]
    Set xlwkbk = xlApp.Workbooks.Open("C:\Documents\Undelivered.xlsx") [COLOR="Red"]'istenilen klasör ve dosya ismine uyarlanacak[/COLOR]
End If

Set xlwksht = xlwkbk.Sheets(1)
Set xlRng = xlwksht.Range("A1")
xlApp.ScreenUpdating = False
xlRng.Value = "Bounced email addresses"
' resize version
xlRng.Offset(1, 0).Resize(UBound(badAddresses) + 1).Value = xlApp.Transpose(badAddresses)
xlApp.Visible = True
xlApp.ScreenUpdating = True

ExitProc:
Set xlRng = Nothing
Set xlwksht = Nothing
Set xlwkbk = Nothing
Set xlApp = Nothing
Set olFolder = Nothing
Set olNS = Nothing
Set olApp = Nothing
Set badAddresses = Nothing

End Sub

Function GetExcelApp() As Object
 
' always create new instance
On Error Resume Next
Set GetExcelApp = CreateObject("Excel.Application")
On Error GoTo 0

End Function

Function IsFileOpen(FileName As String)

Dim iFilenum As Long
Dim iErr As Long
 
On Error Resume Next
iFilenum = FreeFile()
Open FileName For Input Lock Read As #iFilenum
Close iFilenum
iErr = Err
On Error GoTo 0
 
Select Case iErr
    Case 0: IsFileOpen = False
    Case 70: IsFileOpen = True
    Case Else: Error iErr
End Select
 
End Function