Outlook mailleri veya eklerini diske otomatik kaydetme

[askm]

Hayırlı akşamlar.
http://excel.bayramdede.com/2013/12/25/outlook-mailleri-veya-eklerini-diske-otomatik-kaydetme/
linkde gelen mailleri diske kaydetme var. Yalnız kural oluşturmak gerekli.Bu kodları Public Sub SaveMailDisk(itm As Outlook.MailItem) şeklinde değil de Sub SaveMail şeklinde nasıl yapabiliriz. Yani Outlookda geliştirici - makrolardan manuel çalıştırmak istiyorum.
2. Bir sorum da bu kodu sadece seçmiş olduğum klasörde nasıl çalıştırabilirim. Yani mesela gelen kutusu seçdiğimde sadece gelen kutusundaki mailleri aktarsın. konuşma geçmişi seçmişsem ondakileri kaydetsin gibi. Bu seçme işlemi klasör seçili iken kodu çalıştırma şeklinde de olabilir, Application ile de seçilebilir.

 

[askm]

İlgili linkdeki kodlar;

Public Sub SaveMailDisk(itm As Outlook.MailItem)
 On Error Resume Next
 Dim saveFolder As String
 saveFolder = "D:\OUTLOOK YEDEK\" 'Maillerin kaydedileceği dosya
 Dim dateFormat
 dateFormat = Format(itm.ReceivedTime, "yyyy-mm-dd HH-mm-ss") ' Mailin dosya adına alınma zamanını eklemek için
 Dim dosyaadi As String
 dosyaadi = saveFolder & "\[" & dateFormat & "] [" & itm.Sender.Name & "] [" & degistir(itm.Subject) & "].msg"
 itm.SaveAs dosyaadi ' Maili diske kaydeder.

For Each objAtt In itm.Attachments 'Mail'deki ekleri diske kaydeder.
objAtt.SaveAsFile saveFolder & "\[" & dateFormat & "] [" & itm.Sender.Name & "] [" & degistir(itm.Subject) & "] " & objAtt.DisplayName
Set objAtt = Nothing
Next

End Sub

Function degistir(yazi As String) 'Dosya adındaki geçersiz karakterleri temizler
On Error Resume Next
yk = "_" 'Geçersiz karakterin yerine ne koyacağız?
yazi = Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(yazi, ":", yk), "*", yk), "\", yk), "/", yk), "<", yk), ">", yk), "|", yk), """", yk), "?", yk)
degistir = yazi
End Function

 

[Asri]

Bu şekilde dener misiniz?
Diyalog penceresi açılacak ve seçilen klasördeki mailler kayıt edilecektir.

   Public Sub mailleri_kaydet()
  Dim coll As VBA.Collection
  Dim obj As Object
  Dim Atts As Outlook.Attachments
  Dim Att As Outlook.Attachment
  Dim Sel As Outlook.Selection
  Dim i&, Msg$
  Dim lFileNr As Long
 
   Set objNS = Application.GetNamespace("MAPI")
    Set Inbox = objNS.PickFolder

    If TypeName(Inbox) <> "Nothing" Then
       If Inbox.Items.Count = 0 Then
          MsgBox "Seçilen " & Inbox & " klasöründe mail bulunamadı", vbInformation, "Mail bulunamadı."
          Exit Sub
       End If
    Else
        Set Inbox = Nothing
        Set objNS = Nothing
        Exit Sub
    End If

  kaydetklasor = "c:\temp"
  For Each obj In Inbox.Items
      sExt = ".msg"
      sname = isimtemizle(obj.Subject)
      dtDate = obj.ReceivedTime
      sname = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
      vbUseSystem) & Format(dtDate, "-hhnnss", _
      vbUseSystemDayOfWeek, vbUseSystem) & "-" & sname & sExt
      obj.SaveAs kaydetklasor & "\" & sname, olSaveAsMsg
 
  Next
End Sub

Function isimtemizle(strFileNameIn As String) As String
    Dim i As Integer
    Const strIllegals = "\/|?@*<>"":"
    For i = 1 To Len(strIllegals)
        strFileNameIn = Replace(strFileNameIn, Mid$(strIllegals, i, 1), "_")
    Next i
    isimtemizle = strFileNameIn
End Function

 

[askm]

Sayın Asri ilginiz için teşekkür ederim. Yalnız isimtemizle adında bir function olması gerekli sanırım.

 

[Asri]

Ekledim. Sizin kodlarınızdaki degiştir belki daha iyidir. Denemek lazım.

 

[askm]

Sayın asri ilginiz için teşekkürler. Kod seçilen mailleri kaydediyor. Seçilen mailler değil de outlookdaki aktif klasör ya da seçilen klasördeki tüm mailleri kaydetme imkanı var mı?

 

[Asri]

Sayın asri ilginiz için teşekkürler. Kod seçilen mailleri kaydediyor. Seçilen mailler değil de outlookdaki aktif klasör ya da seçilen klasördeki tüm mailleri kaydetme imkanı var mı?

Ctrl + A ve kodu çalıştırın

Var tabiki bakmam lazım. Bugün geç olur belki olmaz ise yarın dönüş yaparım.

 

[askm]

İlginiz için tekrar çok çok teşekkürler.

 

[Asri]

Kod güncellendi.
Diyalog penceresi açılacak ve seçilen klasördeki mailler kayıt edilecektir.

 

[askm]

Sayın Asri, sabah deneyeceğim. Hayırlı akşamlar.

 

[askm]

Sayın Asri teşekkürler. Kod işime yaradı. Bu kodu Excelden ya da bat dosyası ile calistirabilir miyiz. Format sonrası kodlar siliniyor. Bunun önüne geçmiş oluruz.

 

[Asri]

Sayın Asri teşekkürler. Kod işime yaradı. Bu kodu Excelden ya da bat dosyası ile calistirabilir miyiz. Format sonrası kodlar siliniyor. Bunun önüne geçmiş oluruz.

Bu dosyanın yedeğini alın, format sonrası aynı yere kopyalayın.
Outlook daki tüm kodlarınız geri gelecektir.

copy "C:\Users\kullanici.adiniz\AppData\Roaming\Microsoft\Outlook\VbaProject.OTM"

 

[askm]

Buranın yedeğini aldım. Ama Excel ya da bat daha kolay olacaktır.

 

[akinx]

Bu şekilde dener misiniz?
Diyalog penceresi açılacak ve seçilen klasördeki mailler kayıt edilecektir.

   Public Sub mailleri_kaydet()
  Dim coll As VBA.Collection
  Dim obj As Object
  Dim Atts As Outlook.Attachments
  Dim Att As Outlook.Attachment
  Dim Sel As Outlook.Selection
  Dim i&, Msg$
  Dim lFileNr As Long

   Set objNS = Application.GetNamespace("MAPI")
    Set Inbox = objNS.PickFolder

    If TypeName(Inbox) <> "Nothing" Then
       If Inbox.Items.Count = 0 Then
          MsgBox "Seçilen " & Inbox & " klasöründe mail bulunamadı", vbInformation, "Mail bulunamadı."
          Exit Sub
       End If
    Else
        Set Inbox = Nothing
        Set objNS = Nothing
        Exit Sub
    End If

  kaydetklasor = "c:\temp"
  For Each obj In Inbox.Items
      sExt = ".msg"
      sname = isimtemizle(obj.Subject)
      dtDate = obj.ReceivedTime
      sname = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
      vbUseSystem) & Format(dtDate, "-hhnnss", _
      vbUseSystemDayOfWeek, vbUseSystem) & "-" & sname & sExt
      obj.SaveAs kaydetklasor & "\" & sname, olSaveAsMsg

  Next
End Sub

Function isimtemizle(strFileNameIn As String) As String
    Dim i As Integer
    Const strIllegals = "\/|?@*<>"":"
    For i = 1 To Len(strIllegals)
        strFileNameIn = Replace(strFileNameIn, Mid$(strIllegals, i, 1), "_")
    Next i
    isimtemizle = strFileNameIn
End Function

teeee 2005'teki konuyu tekrar canlandırayım

Kod aktif ve güzel çalışıyor. öncelikle emeklerinize sağlık. 14 sene sonra tekrar birinin işine yaradı. ama azıcık geliştirmek adına destek rica edeceğim.

Şöyle ki; turizm sektöründe çalışıyorum ve yaz sezonunda ortalama günde 1500 ile 1800 adet mail almaktayım. bu mailler arasında önemli olanlar var. bunları kaçırmamak ve kaybetmemek adına diske (C:\Users\kullanici.adi\Desktop\Fiyat Mailleri) kaydetmek istiyorum. bu kodu şöyle kullanıyorum. outlook'ta kuralım var. x kişisinden gelen maili y klasörüne taşı şeklinde. ve bu kodu y klasöründe çalıştırıyorum. fakat benim istediğim tamamen otomasyon. yani x kişisinden bir mail düştüğü zaman bunu ben herhangi bir müdahalede bulunmadan diske kaydedecek. bu konuda yardım istemekteyim.

tabi bu outlook'ta herhangi bir yavaşlama ya da performans düşüklüğü yaratır mı? bu da önem verilen bir konu 1500-1800 arası mail sabah 9:00 akşam 18:00 arasında