Outlook Bodysindeki mail adreslerini excele yazırma.

[Rainbows]

Merhabalar,

outlook da to daki ve cc deki mail adreslerini excele cekebiliyorum. fakat bircok mailde mail bodysinde de mail adresi olabiliyor. bu mail adreslerini outlookdan excele alt altta yazdırmam mümkün müdür?

teşekkürler,

kolay gelsin.

 

[PLİNT]

Merhabalar,

mail bodysinde de mail adresi olabiliyor. bu mail adreslerini outlookdan excele alt altta yazdırmam mümkün müdür?

Merhaba
Ek dosya işinize yarayabilir.
http://s5.dosya.tc/server5/dqah07/DENEME.zip.html

[SIZE="2"]Private Sub CommandButton1_Click()
 Dim a As Object, b As Object, c As Object
    Dim s1 As Worksheet
    Dim bdy As String, bdy2 As String
    Dim x As Long, gereksiz As Long, t As Long
    Dim j As Integer
    Dim msg
    j = 1
Set s1 = Sheets("Sayfa1")

s1.Range("A2:B" & Rows.Count) = Empty
    s = s1.Cells(Rows.Count, "B").End(3).Row
    Set a = CreateObject("Outlook.Application")
    Set b = a.GetNamespace("MAPI")
    Set c = b.GetDefaultFolder(6)
    For Each msg In c.Items
 gereksiz = 0
gereksiz = InStr(1, msg.SenderEmailAddress, "Mailer-Daemo", vbTextCompare) + InStr(1, msg.SenderEmailAddress, "postmaster", vbTextCompare)
If gereksiz = 0 Then
If TypeName(msg) = "MailItem" Then
   'If IsEmpty(msg.ReceivedTime) = False And _
    IsEmpty(msg.Sender.Name) = False And IsEmpty(msg.SenderEmailAddress) = False Then
bdy = msg.body
x = UBound(Split(bdy, " "))
If x > 0 Then
For t = 0 To x
bdy2 = Split(bdy, " ")(t)
If InStr(1, bdy2, "@", vbTextCompare) > 0 Then
j = j + 1
Cells(j, 1) = msg.SenderEmailAddress
If UBound(Split(bdy2, Chr(13))) > 0 Then
Cells(j, 2) = Split(Trim(bdy2), Chr(13))(0)
Else
Cells(j, 2) = bdy2
End If
End If
Next
End If
 End If: End If:  'End If
    Next
   
End Sub
[/SIZE]