Outlook Toplu Ek Kaydetme

[xtrkax]

Arkadaşlar merhabalar,

http://image.prntscr.com/image/1b532ad75f3a45b19ce4ad05cd9883ee.png

resimde de göründüğü üzere elimde outlook klasöründe yer alan 1969 tane mail ve ekleri mevcut. Bazısında 1 tane bazısında 5 6 tane ek dosya mevcut. Bunların hepsini toplu bir şekilde masaüstümde bir klasöre kaydetmemin bir yolu var mıdır? Gerçekten çıkamadım işin içinden ve tek tek yapılarak da sanırım çok vaktimi alacaktır. Yardımcı olursnaız çok sevineceğim.

 

[Ömer]

Merhaba,

Linki inceleyin.

http://www.excel.web.tr/f51/outlook-mailleri-sabit-diske-kaydetme-t20335.html

.

 

[PLİNT]

Merhaba
Alternatif olarak,eklerini alacağınız mail kimliğinizi Outlook ta aktif ederek aşağıdaki dosyayı deneyin.
Gelen eklerde aynı isimli birden fazla dosya bulunma ihtimali varsa değişiklik yapalım
http://s6.dosya.tc/server8/1kmpo6/MAIL_EKLERI.zip.html

[SIZE="2"]Private Sub CommandButton1_Click()
 Dim a As Object, b As Object, c As Object
    Dim d As Object, e As Object
    Dim s1, S2 As Worksheet
Set s1 = Sheets("Sayfa1")
s1.Range("A2:E" & Rows.Count) = Empty
Set ds = CreateObject("Scripting.FileSystemObject")
yol = ThisWorkbook.Path & "\"
If ds.FolderExists(yol & "MAİL_DOSYALARI") = False Then ds.CreateFolder yol & "MAİL_DOSYALARI"
yol = yol & "\MAİL_DOSYALARI\"
    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
    If msg.Attachments.Count > 0 Then
 i = i + 1
s1.Cells(s + i, "a").NumberFormat = "dd/mm/yyyy;@"
s1.Cells(s + i, "a") = msg.ReceivedTime
s1.Cells(s + i, "b") = msg.SenderEmailAddress
s1.Cells(s + i, "c") = msg
For say = 1 To msg.Attachments.Count
gt = Left(msg.Attachments(say).Filename, InStrRev(msg.Attachments(say).Filename, ".") - 1)
im = IIf(s1.Cells(s + i, "e") = "", Empty, " / ")
s1.Cells(s + i, "e") = Cells(s + i, "e") & im & gt
s1.Cells(s + i, "D") = Cells(s + i, "D") + 1
s1.Cells(s + i, "D").Select
msg.Attachments(say).SaveAsFile yol & ad & " " & msg.Attachments(say).Filename
Next
 End If: End If: End If:  End If
    Next
End Sub[/SIZE]

 

[burcin_end_muh]

Merhaba,

Linki inceleyin.

http://www.excel.web.tr/f51/outlook-mailleri-sabit-diske-kaydetme-t20335.html

.

bu konuda destek verebilecek var mı?