burcin_end_muh
Altın Üye
- Katılım
- 14 Ocak 2013
- Mesajlar
- 161
- Excel Vers. ve Dili
- Türkçe 2013
- Altın Üyelik Bitiş Tarihi
- 05-01-2028
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
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