Outlook ile 250 Adet Maille Gelen pdf leri Tek Seferde Yedekleme

[kasif2]

Selam;

İşyerine ait telefonları Telekomdan mail olarak talep ettik. Ama 250 ye yakın telefonun epostalarını tek tek açıp içinden dosyaları almak zor oluyor. Bunu outlook bi yere yedekliyor, ben de bu şekilde yedeklediği yerden tek seferde bunları alamaz mıyım?

 

[hamitcan]

Kod, işinizi görür sanırım.

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

 

[kasif2]

deneme@deneme.com olan kısmı mailadresimiz@gmail.com olarak değiştirdim ve C:\ yi D:\ yaptım. Ama herhangibişey olmadı. Acaba bişeyleri yanlış mı yaptım

Mail gönderen: efatura@turktelekom.com.tr

 

[hamitcan]

Hata verdi mi ? Hata verdiyse, Microsoft Outlook XX. ile başlayan referansın seçili olup olmadığına bakın.

 

[Mehmet Şahin]

Merhaba,
dosyayı test ettim, çalışıyor. deneme@deneme.com olan kısmı efatura@turktelekom.com.tr olarak değiştirirseniz ve "C:\" olan bölümü de "D:\faturalar" olarak değiştirirseniz D sürücüsünde açacağınız faturalar klasörüne ekleri atacaktır. Teşekkürler Hamitcan üstad.

 

[kasif2]

Bu şekilde düzenledim. D:\Faturalar klasörü yarattım, Alt+F8 ile çağırıp Çalıştır diyorum ama yine olmadı
Office 2007 kullanıyorum ve işyerindeki makinalarda C 'ye erişim engelli. Bunun etkisi olabilir mi?

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

 

[Mehmet Şahin]

"D:\Faturalar\" şeklinde denermisiniz, iyi çalışmalar.

 

[kasif2]

Bu kadar basitmiş

Sn. hamitcan ve dentex, ikinize de çok çok teşekkürler. Harika oldu, beni büyük bi yükten kurtardınız

 

[cavanoos]

Dentex;

Makro kodunu aşağıdaki şekilde düzelttim.Ama anlam veremediğim sonuçlar oluyor.
1-efatura@turktelekom.com.tr ile ilgili gelen kutusunda 20 adet mail varsa 14 tanesi geliyor.
2-Başka bir adresi yazıyorum.Hiç sonuç yok.

Hatayı nerde yapıyorum ?


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

 

[Mehmet Şahin]

iyi geceler,
gelen dosyalarınız inbox haricinde tanımladığınız bir klasöre mi düşüyor. "On error goto hata" satırını deaktif ederek hata veriyorsa nerde hata verdiğini tesbit etmeye çalışın. Ben işyerinde test etmiştim, gayet güzel çalışıyor.

 

[cavanoos]

Dentex;

Gelen kutusuna düşüyor.Maillerde gelen kutusunda idi işlem yaparken.Herhangi bir hata vermiyor.Düzgün çalışıyor.Ama sonuç yok.

 

[cavanoos]

Dentex;

Nette yapılan araştırmalarımda yeni bir makro kodu buldum ve düzgün çalışıyor.Yalnız sizden bir ricam var.Bu makro kodunda hangi klasör seçili ise onun içindeki bütün xls uzantılı dosyaları bir klasöre kaydediyor.Sizin örneğinizdeki bir mail adresi seçipte sadece o mail adresinden gelenleri nasıl alırız ?

Çok önemli bir sorun değil olmasada olur.Ama olursa daha süper olur



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) = "XLS" 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
'NOT:
'Referanslardan
'Microsoft Outlook X.X Library
'Microsoft Scripting Runtime
'seçili olmalıdır.
'Outlokta Inbox klasörü seçili olmalıdır.
End Sub

 

[Mehmet Şahin]

Hamitcan üstadın kodlarını biraz değiştirdim. Bu şekilde denermisiniz?

Sub Gonderene_Gore()
     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 i = 1 To Inbox.Items.Count
         If Inbox.Items(i).Class = olMail Then
          Set obj = Inbox.Items.Item(i)
           If obj.SenderEmailAddress = "xxxx@xxxx.com" Then
             For Each Atmt In obj.Attachments
                 FileName = "D:\UGUR\" & Atmt.FileName
                 Atmt.SaveAsFile FileName
             Next Atmt
           End If
         End If
        Next
hata:
    Set Atmt = Nothing
    Set Item = Nothing
    Set ns = Nothing
End Sub