Gelen kutusundaki mail eklerini indirmek

cavanoos · 28 Mayıs 2012

Merhaba arkadaşlar;

Gelen kutusundaki maillerde içinde txt uzantılı ekli dosyaları bilgisayarıma indirmek için kullandığım bir makro kodu var.Gayet güzelde çalışıyor.Ancak ekli dosyaların ismi aynı ise bir tanesini alıyor.Diğerini almıyor.

Örnek verirsek 10 adet txt uzantılı dosyanın ismide Garanti ise bir tanesini alıyor.Diğerlerini almıyor.Bu mailleri klasöre kaydederken garanti1 , garanti2 ,garanti3...deme gibi bir şansımız var mıdır ?

Kullandığım kod aşağıdadır.Yardım edebilir misiniz ?

Public Sub SaveAllAttachments()
Dim App As New Outlook.Application
Dim Exp As Outlook.Explorer
Dim Sel As Outlook.Items
Dim AttachmentCnt As Integer
Dim AttTotal As Integer
Dim MsgTotal As Integer
Dim outputDir As String
Dim outputFile As String
Dim fileExists As Boolean
Dim cnt As Integer
Dim fso As FileSystemObject
Set Exp = App.ActiveExplorer
Set Sel = Exp.CurrentFolder.Items
Set fso = New FileSystemObject
outputDir = "D:\UGUR\" 'Klasör Adresi
For cnt = 1 To Sel.Count
If Sel.Item(cnt).Attachments.Count > 0 Then
MsgTotal = MsgTotal + 1
For AttachmentCnt = 1 To Sel.Item(cnt).Attachments.Count
Dim att As Attachment
Set att = Sel.Item(cnt).Attachments.Item(AttachmentCnt)
outputFile = UCase(att.FileName)
If Right(outputFile, 3) = "RAR" Then
fileExists = fso.fileExists(outputDir + outputFile)
Do While fileExists = True
outputFile = InputBox("The file " + outputFile _
+ " already exists in the destination directory of " _
+ outputDir + ". Please enter a new name, or hit cancel to skip this one file.", "File Exists", outputFile)
If outputFile = "" Then
Exit Do
End If
fileExists = fso.fileExists(outputDir + outputFile)
Loop
If fileExists = False Then
att.SaveAsFile (outputDir + outputFile)
AttTotal = AttTotal + 1
End If
End If
Next
End If
Next
Set Sel = Nothing
Set Exp = Nothing
Set App = Nothing
Set fso = Nothing
Dim doneMsg As String
doneMsg = "Completed saving " + Format$(AttTotal, "#,0") + " attachments in " + Format$(MsgTotal, "#,0") + " Messages."
MsgBox doneMsg, vbOKOnly, "Save All Attachments"
Exit Sub
ErrorHandler:
Dim errMsg As String
errMsg = "An error has occurred. Error " + Err.Number + " " + Err.Description
Dim errResult As VbMsgBoxResult
errResult = MsgBox(errMsg, vbAbortRetryIgnore, "Error in Save Attachments")
Select Case errResult
Case vbAbort
Exit Sub
Case vbRetry
Resume
Case vbIgnore
Resume Next
End Select
End Sub

hamitcan · 28 Mayıs 2012

Kaynak:http://www.fontstuff.com/outlook/oltut01.htm

Aşağıdaki kodu da deneyebilirsiniz.

Kod:

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 = "deneme@deneme.com" Then
     For Each Atmt In Item.Attachments
         FileName = "C:\" & Atmt.FileName
         Atmt.SaveAsFile FileName
     Next Atmt
     End If
     Next Item
hata:
End Sub

cavanoos · 28 Mayıs 2012

Sayın Hamitcan;

Makro kodu çalıştı.Ama bir bir şey olmadı.Mail adresini ve klasör yolunu değiştirdim sadece.Sizin koddan farklı olarak..

hamitcan · 28 Mayıs 2012

Outllok referanslarını işaretlediniz mi ?

cavanoos · 28 Mayıs 2012

Microsoft outlook 12.0 library işaretli

hamitcan · 28 Mayıs 2012

1-Inbox klasörünün varsayılan olup olmadığını kontrol ediniz.
2-Gelen postalar içinde ataçlı dosya var mı kontrol ediniz.

baydeniro · 28 Mayıs 2012

Çok ilginç bir kod. Sayın hamitcan, bu kodun çalışıyor ama indirme yapmadı. Sorun ne olabilir ?

hamitcan · 29 Mayıs 2012

Gönderen kısmını kapattım, bir de aşağıdaki şekilde dener misiniz ?

Kod:

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 = "deneme@deneme.com" Then
     For Each Atmt In Item.Attachments
         FileName = "C:\" & Atmt.FileName
         Atmt.SaveAsFile FileName
     Next Atmt
     'End If
     Next Item
hata:
End Sub

cavanoos · 29 Mayıs 2012

Değişen bir şey olmadı.

Benim yazdığım kod gayet güzel çalışıyordu.O kodun içinde eklenti yapamazmıyız ?

Bu forumda hamitcan üstadım gibi başka üstatlarımızda var.Onlarında bu konuda fikirlerini bilmek isterim.

MCAPOWER · 27 Mayıs 2015

Problemi anlayamadım..

cavanoos selam,

Sorun tam olarak nedir? Ben aşağıdaki kodla attachment'lerin .xls olanlarını aldırabildim, belirttiğin gibi sadece 1 dosya alıyordu, ben de IF döngüsünün sonuna ss = ss + 1 ilave ettim, tabi dosyanın adının sonuna da..

Sub GetAttachments()
On Error GoTo GetAttachments_err
' Declare variables
Dim ns As NameSpace
Dim Inbox As MAPIFolder
Dim Item As Object
Dim Atmt As Attachment
Dim FileName As String
Dim ss As Integer
Dim i As Integer
Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
i = 0
' Check Inbox for messages and exit of none found
If Inbox.Items.Count = 0 Then
MsgBox "There are no messages in the Inbox.", vbInformation, _
"Nothing Found"
Exit Sub
End If
' Check each message for attachments
For Each Item In Inbox.Items
' Save any attachments found
For Each Atmt In Item.Attachments
' This path must exist! Change folder name as necessary.
FileName = "D:\OUTLOOK\" & Atmt.FileName
Atmt.SaveAsFile FileName & ss & ".xls"
i = i + 1
ss = ss + 1
Next Atmt
Next Item
' Show summary message
If i > 0 Then
MsgBox "I found " & i & " attached files." _
& vbCrLf & "I have saved them into the D:\OUTLOOK." _
& vbCrLf & vbCrLf & "Have a nice day.", vbInformation, "Finished!"
Else
MsgBox "I didn't find any attached files in your mail.", vbInformation, "Finished!"
End If
' Clear memory
GetAttachments_exit:
Set Atmt = Nothing
Set Item = Nothing
Set ns = Nothing
Exit Sub
' Handle errors
GetAttachments_err:
MsgBox "An unexpected error has occurred." _
& vbCrLf & "Please note and report the following information." _
& vbCrLf & "Macro Name: GetAttachments" _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume GetAttachments_exit
End Sub

Sub SaveAttachmentsToFolder()
' This Outlook macro checks a named subfolder in the Outlook Inbox
' (here the "Sales Reports" folder) for messages with attached
' files of a specific type (here file with an "xls" extension)
' and saves them to disk. Saved files are timestamped. The user
' can choose to view the saved files in Windows Explorer.
' NOTE: make sure the specified subfolder and save folder exist
' before running the macro.
On Error GoTo SaveAttachmentsToFolder_err
' Declare variables
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 i As Integer
Dim varResponse As VbMsgBoxResult
Dim n As String
Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
Set SubFolder = Inbox.Folders("Sales Reports") ' Enter correct subfolder name.
i = 0
' Check subfolder for messages and exit of none found
If SubFolder.Items.Count = 0 Then
MsgBox "There are no messages in the Sales Reports folder.", vbInformation, _
"Nothing Found"
Exit Sub
End If
' Check each message for attachments
For Each Item In SubFolder.Items
For Each Atmt In Item.Attachments
' Check filename of each attachment and save if it has "xls" extension
If Right(Atmt.FileName, 3) = "xls" Then
' This path must exist! Change folder name as necessary.
FileName = "D:\OUTLOOK\" & _
Format(Item.CreationTime, "yyyymmdd_hhnnss_") & Atmt.FileName
Atmt.SaveAsFile FileName
i = i + 1
End If
Next Atmt
Next Item
' Show summary message
If i > 0 Then
varResponse = MsgBox("I found " & i & " attached files." _
& vbCrLf & "I have saved them into the D:\OUTLOOK." _
& vbCrLf & vbCrLf & "Would you like to view the files now?" _
, vbQuestion + vbYesNo, "Finished!")
' Open Windows Explorer to display saved files if user chooses
If varResponse = vbYes Then
Shell "Explorer.exe /e,D:\OUTLOOK", vbNormalFocus
End If
Else
MsgBox "I didn't find any attached files in your mail.", vbInformation, "Finished!"
End If
' Clear memory
SaveAttachmentsToFolder_exit:
Set Atmt = Nothing
Set Item = Nothing
Set ns = Nothing
Exit Sub
' Handle Errors
SaveAttachmentsToFolder_err:
MsgBox "An unexpected error has occurred." _
& vbCrLf & "Please note and report the following information." _
& vbCrLf & "Macro Name: GetAttachments" _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume SaveAttachmentsToFolder_exit

'Call DOSYALARDAN_VERİ_AL

End Sub

cavanoos' Alıntı:
Değişen bir şey olmadı.

Benim yazdığım kod gayet güzel çalışıyordu.O kodun içinde eklenti yapamazmıyız ?

Bu forumda hamitcan üstadım gibi başka üstatlarımızda var.Onlarında bu konuda fikirlerini bilmek isterim.

cavanoos · 28 Mayıs 2015

Merhaba Mcapower;

Mail adresimize 50 adet bankanın ekstresi düşüyor.Hepsi pdf ve hepsinin adı NİSAN AYI EKSTRESİ.Eklerin adı aynı olduğu için indirme yapmıyor.Sorun budur.

Yazmış olduğunuz kodu denedim ama nesne bulunamadı hatası verdi.

halit3 · 28 Mayıs 2015

cavanoos' Alıntı:
Değişen bir şey olmadı.

Benim yazdığım kod gayet güzel çalışıyordu.O kodun içinde eklenti yapamazmıyız ?

Bu forumda hamitcan üstadım gibi başka üstatlarımızda var.Onlarında bu konuda fikirlerini bilmek isterim.

kod:

Kod:

Public Sub SaveAllAttachments()
Dim App As New Outlook.Application
Dim Exp As Outlook.Explorer
Dim Sel As Outlook.Items
Dim AttachmentCnt As Integer
Dim AttTotal As Integer
Dim MsgTotal As Integer
Dim outputDir As String
Dim outputFile As String
Dim fileExists As Boolean
Dim cnt As Integer
Dim fso As FileSystemObject
Set Exp = App.ActiveExplorer
Set Sel = Exp.CurrentFolder.Items
Set fso = New FileSystemObject

[COLOR="Red"]Dim fL As Object
Set fL = CreateObject("Scripting.FileSystemObject")[/COLOR]

outputDir = "D:\UGUR\" 'Klasör Adresi
For cnt = 1 To Sel.Count
If Sel.Item(cnt).Attachments.Count > 0 Then
MsgTotal = MsgTotal + 1
For AttachmentCnt = 1 To Sel.Item(cnt).Attachments.Count
Dim att As Attachment
Set att = Sel.Item(cnt).Attachments.Item(AttachmentCnt)

[COLOR="red"]
say = fL.GetFolder(outputDir).Files.Count + 1
'say = say + 1
outputFile = fL.GetBaseName(UCase(att.Filename)) & say & "." &  fL.GetExtensionName(UCase(att.Filename))
If Right(UCase(att.Filename), 3) = "RAR" Then[/COLOR]

'outputFile = UCase(att.Filename)
'If Right(outputFile, 3) = "RAR" Then

fileExists = fso.fileExists(outputDir + outputFile)
Do While fileExists = True
outputFile = InputBox("The file " + outputFile _
+ " already exists in the destination directory of " _
+ outputDir + ". Please enter a new name, or hit cancel to skip this one file.", "File Exists", outputFile)
If outputFile = "" Then
Exit Do
End If
fileExists = fso.fileExists(outputDir + outputFile)
Loop
If fileExists = False Then
att.SaveAsFile (outputDir + outputFile)
AttTotal = AttTotal + 1
End If
End If
Next
End If
Next
Set Sel = Nothing
Set Exp = Nothing
Set App = Nothing
Set fso = Nothing
Dim doneMsg As String
doneMsg = "Completed saving " + Format$(AttTotal, "#,0") + " attachments in " + Format$(MsgTotal, "#,0") + " Messages."
MsgBox doneMsg, vbOKOnly, "Save All Attachments"
Exit Sub
ErrorHandler:
Dim errMsg As String
errMsg = "An error has occurred. Error " + Err.Number + " " + Err.Description
Dim errResult As VbMsgBoxResult
errResult = MsgBox(errMsg, vbAbortRetryIgnore, "Error in Save Attachments")
Select Case errResult
Case vbAbort
Exit Sub
Case vbRetry
Resume
Case vbIgnore
Resume Next
End Select
End Sub

MCAPOWER · 28 Mayıs 2015

Mail eklerindeki PDF'lerin kaydedilmesi

Cavanoos Merhaba,

Gönderdiğim kodda yer alan

If Right(Atmt.FileName, 3) = "xls" Then bölümündeki "xls" yerine "pdf" yapın,

yine alt taraflarda gördüğün & ".xls" yerine de & ".pdf" olarak değiştirin.

Düzelecektir, olmuyorsa birkaç pdf dosyasını sıkıştırarak gönderirseniz yardımcı olmaya çalışayım.

Teşekkürler.

cavanoos · 28 Mayıs 2015

Arkadaşlar;

Sorunum çözülmüştür.Teşekkür ederim...

halit3 · 28 Mayıs 2015

cavanoos' Alıntı:
Arkadaşlar;

Sorunum çözülmüştür.Teşekkür ederim...

Nasıl çözdünüz bizlerde öğrensek.

cavanoos · 29 Mayıs 2015

Halit3

Yazdığınız kod işimi çözdü.

dragon44760 · 29 Mayıs 2015

kodun

Kod:

Dim fso As FileSystemObject

bölümünde hata veriyor. Hangi referansları kullanmamız gerekmektedir? Konuyu daha ayrıntılı anlatır mısın Halit3 hocam?

cavanoos · 30 Mayıs 2015

Merhaba;

Microsoft Outlook X.X Library
Microsoft Scripting Runtime

Bunları bir dener misin ?

ITOKER · 27 Nisan 2016

bu konu ile ilgili elinde çalışan dosyası olan arkadaşlar örnek paylaşabilir mi,

Saygılarımla.

Gelen kutusundaki mail eklerini indirmek

cavanoos

hamitcan

Uzman

cavanoos

hamitcan

Uzman

cavanoos

hamitcan

Uzman

baydeniro

hamitcan

Uzman

cavanoos

MCAPOWER

cavanoos

halit3

Uzman

MCAPOWER

cavanoos

halit3

Uzman

cavanoos

dragon44760

cavanoos

ITOKER