Outlook Inbox'ta olan maillerin excel de listesini olusturmak

[lon_tokyo]

Merhabalar,

Ihtiyacim oldugundan yapmis oldugum bu basit calismayi sizlerle paylasmak istedim,
outlook adresinize gelen maillerin, sirasiyla basligi, tarihi ve gondericisinin adresini bir liste seklinde olusturmakta,
su anlik sadece gelen kutusu(inbox) u tarayabilmekte, subfolder lari maalesef ekleyemedim, ustalarim el atarsa inbox altinda ki subfolder hatta sub-sub-...-folder lari da taratabilecek bir kod cikartabiliriz, (benimde isime cok yarayacaktir)

kodlar asagida ki gibidir, iyi gunlerde kullanin,

Sub GetFromOutlook()

Dim OutlookApp As Outlook.Application
Dim OutlookNamespace As Namespace
Dim Folder As MAPIFolder
Dim SubFolder As Outlook.MAPIFolder
Dim OutlookMail As Variant
Dim i As Integer
Dim ws As Worksheet

Application.ScreenUpdating = False
myValue = InputBox("Please type the mail adress", "Mail Adress", "")

MailboxName = myValue
Folderr = "Inbox" 'giden-gelen kutusu icin lutfen kendi klasor adiniza gore duzenleme yapiniz
Set OutlookApp = New Outlook.Application
Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")

Set Folder = OutlookNamespace.Folders(MailboxName).Folders(Folderr)

For Each ws In Worksheets
    If ws.Name = "Output123" Then
        Application.DisplayAlerts = False
        Sheets("Output123").Delete
        Application.DisplayAlerts = True
    End If
Next

Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Output123"
        Sheets("Output123").Cells(1, 1).Value = "Mail Subject"
        Sheets("Output123").Cells(1, 2).Value = "Mail Date"
        Sheets("Output123").Cells(1, 3).Value = "Mail Sender"
i = 2

For Each OutlookMail In Folder.Items
On Error Resume Next
    If OutlookMail.Subject <> "" Then
        With Sheets("Output123")
            .Cells(i, 1).Value = OutlookMail.Subject
            .Cells(i, 2).Value = OutlookMail.ReceivedTime
            .Cells(i, 3).Value = OutlookMail.Sender.Address
        i = i + 1
        End With
    End If
Next OutlookMail
Set Folder = Nothing
Set OutlookNamespace = Nothing
Set OutlookApp = Nothing
Application.ScreenUpdating = True
End Sub