mail adreslerini listelemek

[accilisse]

merhaba,
forumda aradım fakat bulamadım. ben MS. Outlook 2007 kullanıyorum ve inbox klasörüme gelen mailleri bir excel dosyasına listelemek istiyorum.
yardımcı olabilecek üstatların yardımını rica ediyorum.

 

[hamitcan]

http://www.excel.web.tr/f14/outlooktaki-mail-adreslerini-excele-kaydetmek-t49855.html

 

[accilisse]

merhaba
sn hamitcan,
benim istediğim adres defterindeki adreslerin kopyalanması değil, inbox içine düşen mail adreslerinin kopyalanması, linkteki örnek pek işimi görmüyor

 

[Korhan Ayhan]

Selamlar,

Aşağıdaki kodu denermisiniz. Kod içindeki kırmızı bölüm bazı üyelerimizde farklı olabilir.

Bu referansı işaretlemek için ALT+F11 ile kod editörünü açın.
TOOLS-REFERENCES menüsünden bahsettiğim seçeneği işaretleyip tamam diyerek işlemi tamamlayın.

Option Explicit
 
Sub OUTLOOK_GELEN_KUTUSU_MAIL_LİSTESİ()
    'Kodun çalışması için referanslardan Microsoft Outlook [COLOR=red]11.0[/COLOR] Object Library seçeneğini aktif yapınız.
    
    Dim Outlook_Uygulaması As Outlook.Application
    Dim Outlook_Mapi As Outlook.Namespace
    Dim Gelen_Kutusu As Outlook.MAPIFolder
    Dim Gelen_Mail As Outlook.MailItem
    Dim Satır As Long
    
    Set Outlook_Uygulaması = New Outlook.Application
    Set Outlook_Mapi = Outlook_Uygulaması.GetNamespace("MAPI")
    Set Gelen_Kutusu = Outlook_Mapi.GetDefaultFolder(olFolderInbox)
    
    Sheets("Sayfa1").Cells.Clear
    Satır = 1
    Cells(Satır, 1) = "KİME"
    Cells(Satır, 2) = "BİLGİ"
    Cells(Satır, 3) = "KONU"
    With Range("A1:C1")
        .Font.Bold = True
        .Font.ColorIndex = 3
    End With
    
    If Gelen_Kutusu.Items.Count = 0 Then
        MsgBox "Gelen Kutusunda mail bulunamadı !", vbExclamation
        Exit Sub
    End If
    
    For Each Gelen_Mail In Gelen_Kutusu.Items
        DoEvents
        
        With Gelen_Mail
            Satır = Satır + 1
            Cells(Satır, 1) = .To
            Cells(Satır, 2) = .CC
            Cells(Satır, 3) = .Subject
        End With
    Next
    
    Set Gelen_Mail = Nothing
    Set Gelen_Kutusu = Nothing
    Set Outlook_Mapi = Nothing
    Set Outlook_Uygulaması = Nothing
    
    MsgBox "Gelen Kutusundaki mail adresleri listelenmiştir.", vbInformation
End Sub

 

[accilisse]

Sayın Korhan Ayhan,
kodlar için çok teşekkür ederim. tam istediğim şeydi.

 

[dgnyuksel]

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

HOCAM MERHABA BENDE OUTLOOKTAN MAİLLERİ ÇEKERKEN BU KODLARI KULLANIYORUM FAKAT ( APPLİCATİON-DEFİNED OR OBJECT-DEFİNED ERROR) HATASI ALIYORUM BUNUN SEBEBİ NE OLABİLİR