Outlooka Bağlı Tüm Mailleri İndirmel

[baydeniro]

Merhaba arkadaşlar,

Aşağıdaki kod ile Outlook a gelen mailleri Excele indirebilirsiniz. Herkesin faydalanması için kullanımınıza sunarım. Ayrıca üstadlardan bir destek ricam var. Bu koda nasıl bir ekleme yapmak lazım ki Outlooka bağlı tüm mail adreslerinden gelen mailleri indirmesi için nasıl bir ekleme yapmak gerekir ?


Option Explicit

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

Sub GetFromInbox()
Const olFolderDrafts = 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(olFolderDrafts)
Set oWS = ActiveSheet

x = Date
lrow = 2
lCalcMode = Application.Calculation
Application.Calculation = xlCalculationManual
GetFromFolder oRootFldr
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
oWS.Cells(lrow, 1).Value = .SenderEmailAddress
oWS.Cells(lrow, 2).Value = .To
oWS.Cells(lrow, 3).Value = .cc
oWS.Cells(lrow, 4).Value = .Subject
oWS.Cells(lrow, 5).Value = .receivedtime

lrow = lrow + 1
End With
End If
Next
For Each oSubFldr In oFldr.Folders
GetFromFolder oSubFldr
Next
End Sub

 

[baydeniro]

Sayın forum adminleri. Merhaba arkadaşlar, bu konuda yer alan kod kısmınız düzelterek tekrar konu açtım. Bu konunun silinmesinde yardımınızı rica ediyorum.