Gelen Maildeki Dosyayı Klasöre Kaydetmek

[monelogg]

Merhaba,
Sayfa1'de "dosyaları al" adında bir buton olsun,
ben bu butona bastığımda gelen maillerin konusunu kontrol etsin,
eğer konu adı "personel istek formu" ise o maildeki dosyayı "C:\gelen_mailler" klasörüne kaydetsin.
Kaydederken (dosya adlarının aynı olmaması için) dosya adlarının sonuna artan bir numara vs. tarzında bir ekleme yapılabilir mi?

Biraz çok şey istedim ama yardım edebilirseniz çok makbule geçer.
Saygılarımla...

 

[cenk e.]

Yanlış mesaj...

 

[monelogg]

Merhaba, bir çözüm buldum, sizlerle paylaşmak istiyorum.
http://www.rondebruin.nl/win/s1/outlook/saveatt.htm
Burada istediğimin neredeyse aynısı yapılmış.
Öncelikli olarak Outlook programını açıp, gelen kutusuna sağ tıklıyoruz ve yeni bir alt klasör oluşturuyoruz.
Bunun adına MyFolder ismini veriyoruz.
Daha sonra Outlook 2010 için Giriş>>Kurallar>>Yeni Kural Oluştur seçeneklerine gidiyoruz.
Kural Oluştur penceresinde "Öğeyi bu klasöre taşı" seçeneğini aktif ediyoruz.
Az önce oluşturduğumuz MyFolder klasörünü seçiyoruz.
Gelişmiş seçenekleri seçip adım adım ilerleyebilirsiniz, ben konusu "Personel İstek Formu" olanları MyFolder klasörüne taşımasını istediğim için onu seçtim ve son butona basarak kapattım.
Bu adımdan sonra bir sub yordam açıp şu kodları kopyalayıp çalıştırabilirsiniz.
İngilizcem iyi değildir ama anladığım kadarıyla böyle.

Sub SaveEmailAttachmentsToFolder(OutlookFolderInInbox As String, _
                                 ExtString As String, DestFolder As String)
    Dim ns As Namespace
    Dim Inbox As MAPIFolder
    Dim SubFolder As MAPIFolder
    Dim Item As Object
    Dim Atmt As Attachment
    Dim FileName As String
    Dim MyDocPath As String
    Dim I As Integer
    Dim wsh As Object
    Dim fs As Object

    On Error GoTo ThisMacro_err

    Set ns = GetNamespace("MAPI")
    Set Inbox = ns.GetDefaultFolder(olFolderInbox)
    Set SubFolder = Inbox.Folders(OutlookFolderInInbox)

    I = 0
    ' Check subfolder for messages and exit of none found
    If SubFolder.Items.Count = 0 Then
        MsgBox "There are no messages in this folder : " & OutlookFolderInInbox, _
               vbInformation, "Nothing Found"
        Set SubFolder = Nothing
        Set Inbox = Nothing
        Set ns = Nothing
        Exit Sub
    End If

    'Create DestFolder if DestFolder = ""
    If DestFolder = "" Then
        Set wsh = CreateObject("WScript.Shell")
        Set fs = CreateObject("Scripting.FileSystemObject")
        MyDocPath = wsh.SpecialFolders.Item("mydocuments")
        DestFolder = MyDocPath & "\" & Format(Now, "dd-mmm-yyyy hh-mm-ss")
        If Not fs.FolderExists(DestFolder) Then
            fs.CreateFolder DestFolder
        End If
    End If

    If Right(DestFolder, 1) <> "\" Then
        DestFolder = DestFolder & "\"
    End If

    ' Check each message for attachments and extensions
    For Each Item In SubFolder.Items
        For Each Atmt In Item.Attachments
            If LCase(Right(Atmt.FileName, Len(ExtString))) = LCase(ExtString) Then
                FileName = DestFolder & Item.SenderName & " " & Atmt.FileName
                Atmt.SaveAsFile FileName
                I = I + 1
            End If
        Next Atmt
    Next Item

    ' Show this message when Finished
    If I > 0 Then
        MsgBox "You can find the files here : " _
             & DestFolder, vbInformation, "Finished!"
    Else
        MsgBox "No attached files in your mail.", vbInformation, "Finished!"
    End If

    ' Clear memory
ThisMacro_exit:
    Set SubFolder = Nothing
    Set Inbox = Nothing
    Set ns = Nothing
    Set fs = Nothing
    Set wsh = Nothing
    Exit Sub

    ' Error information
ThisMacro_err:
    MsgBox "An unexpected error has occurred." _
         & vbCrLf & "Please note and report the following information." _
         & vbCrLf & "Macro Name: SaveEmailAttachmentsToFolder" _
         & vbCrLf & "Error Number: " & Err.Number _
         & vbCrLf & "Error Description: " & Err.Description _
         , vbCritical, "Error!"
    Resume ThisMacro_exit

End Sub

Not: Bir sıkıntım kaldı, bu dosyaların isimleri aynı ise hepsini kaydetmiyor, her dosyayı farklı adla nasıl kaydedebilirim.
Örneğin her dosyayı kaydederken Now makrosu sonucu yanına eklensin.
Mesela DENEMEDOSYASI_10-11-2013-23-22-36.xlsm

 

[monelogg]

Merhaba, tarih işini de şu şekilde hallettim ama yinde de aynı mailden gelen birden fazla dosyayı kaydetmiyor, ne yapmalıyım?

[COLOR="Red"]FileName = DestFolder & Format(Now, "dd-mmm-yyyy hh-mm-ss") & Item.SenderName & " " & Atmt.FileName
[/COLOR]

 

[Mehmet Şahin]

Merhaba,
ekteki kodları çalıştırmıştım. Sanırım onlar da monelogg arkadaşın verdiği adresten alınmıştı. Belirtilen klasörü ( c:\arşiv) oluşturmalısınız İyi çalışmalar.

Sub Gonderene_Gore_Outlook_Maillerini_Kaydetme()
     Dim ns As Namespace
     Dim Inbox As MAPIFolder
     Dim Item As Object
     Dim Atmt As Attachment
     Dim FileName As String
     
     On Error GoTo hata
     Set ns = GetNamespace("MAPI")
     Set Inbox = ns.GetDefaultFolder(olFolderInbox)
    
     If Inbox.Items.Count = 0 Then
        MsgBox "Hiçbir Mesaja Rastlanmadı.", vbInformation, _
               "Hiçbir Şey Bulunamadı"
        Exit Sub
     End If
     
     For Each Item In Inbox.Items
     If Item.SenderEmailAddress = "xxxx@xxxx.com" Then
     For Each Atmt In Item.Attachments
         FileName = "c:\arşiv\" & Atmt.FileName
         Atmt.SaveAsFile FileName
     Next Atmt
     End If
     Next Item
hata:
End Sub

 

[cenk e.]

Yanlış mesaj...

 

[monelogg]

Merhaba, Sn. dantex cevabınız için teşekkür ederim, dediklerinizi yaptım, kodu çalıştırdım fakat arşiv klasörüne dosya gelmiyor.

Not: Kusura bakmayın, iki kişi kullanınca bilgisayarı (ve siteyi), açık hesabı bulunca çıkış yapmayı unutuyorum.
monelogg

 

[monelogg]

Ayrıca bir kaç şey aklıma geldi ama tam olarak istediğim gibi olmadı maalesef.

1. Bir dosyaya tarih ekledikten sonra 1 sn. bekletmek.

Application.Wait(Now) + TimeValue("00:00:01")

Bu formu değiştirip kullanacağım ve gelen formlar çok daha fazla sayıda olabilecek. Bu yüzden süre çok uzayabilir.

2. Kod parçasının başına a=1 ekleyip

FileName = DestFolder & Format(Now, "dd-mmm-yyyy hh-mm-ss")[COLOR="Red"] & a &[/COLOR] Item.SenderName & " " & Atmt.FileName
a=a+1

şeklinde yazıp bekletmeden almak. Fakat bu da dosyaların alınmamasına sebep olabilir.

3. Kod parçasının başına

static a
a=0
a=a+1

ekleyip aşağıdaki kodu da şu şekilde düzenlediğimizde

FileName = DestFolder & Format(Now, "dd-mmm-yyyy hh-mm-ss")[COLOR="Red"] & a &[/COLOR] Item.SenderName & " " & Atmt.FileName

son sayıyı hafızada tutuyor fakat çalışma kitabını kapatıp tekrardan açtığınızda a tekrardan 0'dan başlıyor.
İlk kodda her seferinde ayrı bir klasöre kaydediyor ama ben aynı klasöre kaydetsin istiyorum.
Yardımcı olabilirseniz çok sevinirim.

 

[monelogg]

Merhaba, fikri olan var mıdır?