PDA

Orijinalini görmek için tıklayınız : (OUTLOOK) Gelen E-Posta Eklerini Klasöre Kaydetmek.



osman026
12.06.2006, 09:55
Outlook express kullanıyorum.

E-Posta ile gelen eklerin tamamını değil de; mesela sadece 17 ile başlayan excel dosyası eklerini C:\Veri klasörüne kaydetmek istiyorum.

Böyle birşey mümkün mü ?

Bülent
15.06.2006, 17:26
Microsoft Outlook için aşağıdaki kodları kullanabilirsiniz.
Ancak Otlook Express için geçerli değil.

Sub Düğme1_Tıklat()
Dim OLF As Outlook.MAPIFolder, CurrUser As String
Dim EmailItemCount As Integer, i As Integer, EmailCount As Integer

On Error Resume Next

Set OLF = GetObject("", "Outlook.Application").GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)

Set myNewFolder = OLF.Folders(6)

EmailItemCount = myNewFolder.Items.Count
i = 0: EmailCount = 0
While i < EmailItemCount
i = i + 1
With OLF.Items&#40;i&#41;
EmailCount = EmailCount + 1
If .Attachments.Count > 0 Then
For ek = 1 To .Attachments.Count
If Left&#40;.Attachments.Item&#40;ek&#41;.DisplayName, 2&#41; = 17 Then .Attachments.Item&#40;ek&#41;.SaveAsFile "C&#58;\Veri\" & .Attachments.Item&#40;ek&#41;.DisplayName
Next
End If
End With
Wend

Set OLF = Nothing
Set myNewFolder = Nothing
End Sub


Şükür, forum açılmış. Kaç gündür bu cevabı göndermek için bekledim.

osman026
19.06.2006, 12:08
Bülent bey çok teşekkür ederim.

Outlook Expressten Microsoft Outlooka geçiş biraz zaman aldığı için ancak
şimdi deneme imkanım oldu.

Ama maalesef ekleri istediğim klasöre atmıyor.

Acaba referanslardan eklemem gereken bir kütüphane mi var?

Bülent
19.06.2006, 13:45
Acaba referanslardan eklemem gereken bir kütüphane mi var?
Microsoft Outlook Object Library'yi işaretlemeniz gerekir.
Bir hata mesajı aldınız mı? Yoksa sadece istediğiniz neticeyi mi alamadınız?

osman026
19.06.2006, 15:54
Sub deneme&#40;&#41;


Const olFolderInbox = 6

Set objOutlook = CreateObject&#40;"Outlook.Application"&#41;
Set objNamespace = objOutlook.GetNamespace&#40;"MAPI"&#41;
Set objFolder = objNamespace.GetDefaultFolder&#40;olFolderInbox&#41;

Set colItems = objFolder.Items

For Each objMessage In colItems
intCount = objMessage.Attachments.Count
If intCount > 0 Then
For i = 1 To intCount
objMessage.Attachments.Item&#40;i&#41;.SaveAsFile "C&#58;\Veri\" & _
objMessage.Attachments.Item&#40;i&#41;.Filename
Next
End If
Next


End Sub


Microsoftun sitesinden aldığım bu makroda tümünü kaydediyor.

Sizin yazdığınız makro ise While den direk Set OLF = Nothing'e atlıyor

osman026
20.06.2006, 09:20
Teşekkürler Bülent bey hallettim.


While i <= EmailItemCount


Şeklinde yapınca düzeldi.