PDA

Orijinalini görmek için tıklayınız : (OUTLOOK) E-Postadaki dosyaları gönderene göre farklı kayıt



radeon07
05.07.2006, 14:46
outlokda birinden gelen maildeki ek dosyasını dışardaki C:\... herhangi bir klasöre taşıma makrosu arıyorum.

diğer programlarla excel in ilişkisi başlıklı foruma baktım ama bu tüm outlokdaki iletirilerin eklerini almaya çalışıyor ve biyerden sonrada program kitlenip kalıyor.
oyüzden gelen mail adresine göre xx@ adlı kullanıcıdan mesela c:\1 klasörüne taşımak için nasıl bir makro kullanmalıyız?

teşekkürler

Erdinç E. Karaçam
13.07.2006, 16:00
Merhaba,

Outlook makroları konusunda çok bilgim yok ancak biraz dış kaynaklı destek ile istediğinize bir çözüm ürettim.

Yiğidi öldür ama hakkını yeme demişler :lol:
Bu kodların bir kısmının özgün hali Martin Green'e, bir kısmı, Slovak Technical Services'e bir kısmı bendenize aittir.

Önemli Not: Makroyu kullanmadan önce lütfen denetleyiniz;
VBE Penceresi | Tools | References | Microsoft CDO 1.21 Library Etkin olmalıdır.

Önemli Not:
Kodları çalıştırınca Outlook izin ile ilgili iki soru penceresini ekrana getirecek, dakika ayarını değiştirmeden "Evet" diyerek pencereleri geçiniz.
Dedimya Outlook makroları hakkında fazla bilgim yok diye onun için o pencereleri iptal edecek bir kod yazamadım, artık o kadar kusurumuz olsun, değil mi? :D

Önemli Not: Bu makro'yu Outlook 2003'te test ettim, eski sürümlerde belki 2000 ve 2002'de de çalışabilir, emin değilim. Ayrıca Outlook 97'de çalışmayacaktır. Bu ise kesin bir bilgi.


Örnek için öncelikle:
C:\ dizininde HerhangiBirKlasor isimli bir klasör oluşturun.
Ben örneği test için kodda kendi e-posta adresimi yazdım malum siz kendi koşulunuza göre uyarlarsınız artık.

Outlook'ta yazacağınız makro aşağıdaki gibidir.
Yazdığınız bu makronun module adını Module1'den EPostaEklentileriniFarklıKaydet olarak değiştiriniz.

Kodu çalıştırdığınızda dosya uzantısı ne olursa olsun, belittiğimiz klasöre ilgili eklentileri şipşak kaydediyor.

İyi çalışmalar dilerim.


Public Sub GondericiAdresi()

Dim objOutlook As Outlook.Application
Dim objItem As Outlook.MailItem
Dim objSession As MAPI.Session
Dim objMsg As MAPI.Message
Dim objSender As MAPI.AddressEntry
Dim strAddress As String
Dim strName As String
Dim strEntryID As String
Dim IstenenAdres As String
Dim Adres As String

IstenenAdres = "erdinc_karacam@yahoo.com"

On Error Resume Next

Set objOutlook = CreateObject("Outlook.Application")
Set objItem = objOutlook.ActiveInspector.CurrentItem

strName = objItem.SenderName
strEntryID = objItem.EntryID

Set objSession = CreateObject("MAPI.Session")
objSession.Logon "", "", False, False
Set objMsg = objSession.GetMessage(strEntryID)
Set objSender = objMsg.Sender
strAddress = objSender.Address

Adres = strAddress

objSession.Logoff

Set objItem = Nothing
Set objSession = Nothing
Set objMsg = Nothing
Set objSender = Nothing
Set objOutlook = Nothing

If Adres = IstenenAdres Then Call EPostaEklentileriniFarklıKaydet

End Sub


Sub EPostaEklentileriniFarklıKaydet()

On Error GoTo EklentileriAl_Hata

Dim IsimAlani As NameSpace
Dim GelenKutusu As MAPIFolder
Dim GelenEklenti As Object
Dim Eklenti As Attachment
Dim DosyaAdi As String
Dim i As Integer

Set IsimAlani = GetNamespace("MAPI")
Set GelenKutusu = IsimAlani.GetDefaultFolder(olFolderInbox)

i = 0

If GelenKutusu.Items.Count = 0 Then
MsgBox "Gelen Kutusunda ileti yok.", vbInformation, "İleti Bulunamıyor"
Exit Sub
End If


For Each GelenEklenti In GelenKutusu.Items
For Each Eklenti In GelenEklenti.Attachments
DosyaAdi = "C:\HerhangiBirKlasor\" & Eklenti.FileName
Eklenti.SaveAsFile DosyaAdi
i = i + 1
Next Eklenti
Next GelenEklenti

If i > 0 Then
MsgBox i & " adet ilave edili dosya bulundu." & vbCrLf & "İlgili dosyalar C:\HerhangiBirKlasor isimli klasöre kaydedildi." & vbCrLf & vbCrLf & "İyi günler dilerim.", vbInformation, "Bitti!"
Else
MsgBox "E-Postanızda herhangi bir ilave edilmiş dosya bulunamadı.", vbInformation, "Bitti!"
End If

Terket:

Set Eklenti = Nothing
Set GelenEklenti = Nothing
Set IsimAlani = Nothing
Exit Sub

EklentileriAl_Hata:

MsgBox "Beklenmeyen bir hata oluştu." & vbCrLf & "Lütfen aşağıdaki bilgileri dikkate alınız." & vbCrLf & "Makro Adı: EPostaEklentileriniFarklıKaydet" & vbCrLf & "Hata Numarası: " & Err.Number & vbCrLf & "Hata Açıklaması: " & Err.Description, vbCritical, "Hata!"

Resume Terket

End Sub