EXCEL TARİHE GÖRE MAİL EKİ İNDİRME

[ShizzLe]

Dostlar merhaba,

Aşağıdaki dosyadan mail eklerini indirebiliyorum.Fakat ben belirlediğim tarihteki ve belirlediğim klasördeki mail eklerini indirmek istiyorum. Nerelerde degısıklıkler yapmam gerekıyor yardımlarınızı rica ediyorum.

Attachment Found.xlsb

drive.google.com

 

[mancubus]

kodların kaynağı 10 yıldan fazladır güncellenmeyen aşağıdaki site görünüyor.

link çalışmıyor ama site hala aktif. ve Outlook kısmında bu var.

VBA bilginiz olduğunu ve orijinal kodları uyarladığınızı varsayarak sorularınıza cevap vermeye gayret edeyim.

belirlediğim klasör (Inbox'ın altında olduğu düşünülerek):

Set olFolder = objNS.GetDefaultFolder(olFolderInbox).Folders("Mesajların_Aranacağı_Klasörün_Adı")

belirlediğim tarih:

Format(olMail.ReceivedTime, "dd.mm.yyyy") = "25.01.2021"

 

[mancubus]

sadeleştirilmiş önerim:
sadece zip formatı değil tüm ekleri kaydeder. amaç zip ise ilgili satırlardaki tek tırnak işaretlerini silin.
tabii kodun içindeki örnek tarihi de ihtiyaca göre düzeltmek lazım.
inputbox ile de alınabilir.

Sub xlTR_192894_AttachmentDownload()

    Dim olNS As Outlook.Namespace
    Dim olFolder As Outlook.MAPIFolder
    Dim olMail As Outlook.MailItem
    Dim att As Outlook.Attachment
    Dim attPath As String
    Dim ws As Worksheet
  
    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
    End With
  
    Set olNS = GetNamespace("MAPI")
    Set olFolder = olNS.GetDefaultFolder(olFolderInbox).Folders("Mesajların_Aranacağı_Klasörün_Adı") 'inbox'ın içindeki bir klasör. değiştirlebilir.
    'Set olFolder = olNS.PickFolder 'veya kendimiz seçmek için
    Set ws = Sayfa1
  
    attPath = Environ("USERPROFILE") & "\" & "Desktop" & "\" & "Attachments Folder"
    If Dir(attPath, vbDirectory) = vbNullString Then
        MkDir (attPath)
    End If
  
    With ws
        .Cells.Clear
        .Range("A1").Value = "Email Subject"
        .Range("B1").Value = "Attachment Count"
    End With
    y = 2
  
    For Each olMail In olFolder.Items
        If TypeName(olMail) = "MailItem" And olMail.Attachments.Count > 0 And Format(olMail.ReceivedTime, "dd.mm.yyyy") = "25.01.2021" Then
            With ws
                .Cells(y, 1) = olMail.Subject
                .Cells(y, 2) = olMail.Attachments.Count
            End With
          
            On Error Resume Next
          
            For Each att In olMail.Attachments
    '            If InStr(att.FileName, ".zip") > 0 Then
                    att.SaveAsFile attPath & "\" & att.FileName
    '            End If
            Next
            y = y + 1
        End If
    Next
  
    With ws
        .Range("A1:B1").EntireColumn.AutoFit
    End With

End Sub

 

[ShizzLe]

Yanıtınız için teşekkür ederim. inboxu manuel seçip tarihi de belirttikten sonra excel makroyu calıstırıyor bu dakikalarca devam ediyor fakat herhangi bir indirme işlemi yapmıyor.

 

[mancubus]

sorunsuz çalıştığını test ettikten sonra buraya yazmıştım.

seçili klasörde belirtilen tarihte gelmiş mail var mı?
evet ise bu maillerde eklenti var mı?