Mail ekini indirme

[burcin_end_muh]

Merhabalar,

Bir dosya buldum doğru şekilde çalışıyor.
gelen kutusundaki xls dosyalarını masaüstüne indiriyor.

ancak bazı düzeltmeler gerek.
kısıtlamalar getirmek istiyorum.
sadece konusu x olan ve okunmamıslar içinde arasın

değerli zamanınız için teşekkürler

https://we.tl/t-KeUstwHIb0




Sub AttachmentDownload()

Dim objNS As Outlook.Namespace: Set objNS = GetNamespace("MAPI")
Dim olFolder As Outlook.MAPIFolder

Dim item As Object
Dim at As Outlook.Attachment
Dim sname As String
Dim stdir As String
Dim ws As Worksheet
Dim emailcnt As Integer

Set olFolder = objNS.GetDefaultFolder(olFolderInbox)

ThisWorkbook.Activate
Set ws = Sayfa1

un = "Dear " & Environ("UserName")

emailcnt = InputBox("Enter a Number for Email Count", un, 10)
If IsNumeric(emailcnt) = False Then
mb = MsgBox("Default Value of 10 Selected", vbExclamation, un)
emailcnt = 10
emailcnt = emailcnt * 1
End If

With Application
.DisplayAlerts = True
.ScreenUpdating = True
End With

With ws
.Range("A1").Value = "Email Subject"
.Range("B1").Value = "Attachment Count"
End With

y = ws.Cells(Rows.Count, 1).End(xlUp).Row
y = y + 1
stdir = Environ("USERPROFILE") & "\" & "Desktop" & "\" & "Attachments Folder"

If Dir(stdir, vbDirectory) = vbNullString Then
MkDir (stdir)
End If

For Each item In olFolder.Items
If TypeOf item Is Outlook.MailItem Then
Dim oMail As Outlook.MailItem: Set oMail = item

With ws
.Cells(y, 1) = oMail.Subject
.Cells(y, 2) = oMail.Attachments.Count
End With

On Error Resume Next

For Each at In oMail.Attachments
If VBA.InStr(at.Filename, ".xls") > 0 Then
at.SaveAsFile stdir & "\" & at.Filename
End If
Next
y = y + 1
If y = emailcnt Then
mb1 = MsgBox("Searching First " & emailcnt & " Email Finished", vbInformation, un)
GoTo sonlandır:
End If
End If
Next

sonlandır:

With ws
.Range("A1:B1").EntireColumn.AutoFit
End With

With Application
.DisplayAlerts = True
.ScreenUpdating = True
End With

End Sub

 

[burcin_end_muh]

güncel

 

[burcin_end_muh]

hatta bir takım kodlar buldum ama uyarlayamadım

https://www.fontstuff.com/outlook/oltut01.htm