outlook: mailleri sabit diske kaydetme

[muratsedef]

Merhaba arkadaslar,

Outlookta gelen mailleri txt uzantili olarak sabit diske kaydetmenin yolu var mi. Buna uygun bir makro yazabilecek olanlara cok tesekkürler. Mailler zaten html uzantili degil. Txt olarak kaydedilmeye uygunlar.

Cok arastirdim bu konuyu. Maillerin eklerini otomatik olarak kaydeden bir makro buldum. Onu size iletiyorum. Birinin isine yarayabilir.

Ama benim istedigim mailin body kismini kaydetmek.

Ilgilenen herkeze tesekkürler




*******Mail Eklerini Diske Kaydeden Kod*************


Public WithEvents myOlItems As Outlook.Items

Private Sub Application_Startup()
Set myOlItems = _
Outlook.Session.GetDefaultFolder(olFolderInbox).Items
End Sub

Private Sub myOlItems_ItemAdd(ByVal Item As Object)
Const sPfad As String = "C:\KayitDosyasi\"

Dim iAttachCnt As Integer
Dim i As Integer

If TypeName(Item) = "MailItem" Then
With Item.Attachments
iAttachCnt = .Count
If iAttachCnt > 0 Then
For i = 1 To iAttachCnt
.Item(i).SaveAsFile sPfad & .Item(i).FileName
Next i
End If
End With
End If
End Sub

 

[encrypt]

yardım

bunu nereye kopyalıycaz nasıl çalıstırıcaz bi bilgisi olan warsa anlatabilirmi lütfen. bende böyle bişey arıyordum burda gördüm üye oldum yardım almak için. otomatik kaydetmesini istiyorum gelen maillerdeki ekleri yada mevcut maillerdeki ekleri nasıl halledicem?

 

[hamitcan]

Excel-Araçlar-Vba içinde bir modül oluşturup içine yapıştırın.

 

[baydeniro]

Çok teşekkürler. Çok işime yarayacak

 

[accilisse]

sadece excel@excel.web.tr den gelen maillerin ekli dosyalarını kaydetmesini istiyorum. bunun için aşağıdaki kodda nasıl bir değişiklik yapmalıyım.

Public WithEvents myOlItems As Outlook.Items

Private Sub Application_NewMail()
Set myOlItems = _
Outlook.Session.GetDefaultFolder(olFolderInbox).Items
End Sub

Private Sub myOlItems_ItemAdd(ByVal Item As Object)
Const sPfad As String = "C:\deneme\"

Dim iAttachCnt As Integer
Dim i As Integer

If TypeName(Item) = "MailItem" Then
With Item.Attachments
iAttachCnt = .Count
If iAttachCnt > 0 Then
For i = 1 To iAttachCnt
.Item(i).SaveAsFile sPfad & .Item(i).FileName
Next i
End If
End With
End If
End Sub

 

[accilisse]

yardım edebilecek kimse yokmu

 

[hamitcan]

Aşağıdaki siteden bulduğum örneği, kendime göre uyarladım. Ve sorunu çözdüm.Tabii ki kodu, daha fazla geliştirmekte mümkün.
http://www.fontstuff.com/outlook/oltut01.htm

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

 

[accilisse]

teşekkürler hamitcan

 

[ibrahim82]

beceremedim

yapamadım.

Vba falan filan uğraştım ama olmadı.
Ek halinde yollasanız olmaz mı??

 

[hamitcan]

yapamadım.

Vba falan filan uğraştım ama olmadı.
Ek halinde yollasanız olmaz mı??

Bir Module içine aşağıdaki kodu ekleyip çalıştırın.

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'Buraya Mail kimden geliyorsa adresini yazın.
     For Each Atmt In Item.Attachments
         FileName = "C:\" & Atmt.FileName
         Atmt.SaveAsFile FileName
     Next Atmt
     End If
     Next Item
hata:
End Sub

 

[ibrahim82]

Olmadı!

resim ekte

 

[ibrahim82]

olmadı olmadı olmuyor.
Olmıcak mı?

 

[hamitcan]

Referanslardan ilgili Outlook ile ilgili olanı işaretlemeniz gerekiyor.

 

[ibrahim82]

Bu iş , ağaç nerde balta kesti , balta nerde suya düştüye döndü.

Referanslar nerede ve nasıl referansları göstereceğim.
İnanın bahsettiğiniz konuyu anlayamadım.
Başka explorer sayfalarına da baktım fakat iligi konu yok.:frown:

 

[hamitcan]

[qoute]Bu iş , ağaç nerde balta kesti , balta nerde suya düştüye döndü. .

Bence bu sıkıntınızı, Microsoft'a anlatın. Bu konuda bizim yapabileceğimiz birşey yok, referanslar olmadan bu değişkenler çalışmıyor.Ayrıca forumu tam olarak inceleseydiniz, konu ile ilgili birçok çözüme ulaşabilirdiniz, hatta bu soruları belki de şu anda sormamış olacaktınız.
Neyse sorunuza gelelim. Aşağıdaki aşamaları takip edin.
1-Alt+F11
2-Tools>References
3-Microsoft Outlook XXX referansını seçin

 

[pars81]

merhaba arkadaşlar benzer konuda yardıma ihtiyacım var outlook 2010 kullanıyorum belli bir adresten gelen maildeki pdf ve dwg eklerini masaüstünde bir klasör açıp maillere gönder al dediğimde o adresten gelen maildeki ekleri o klasöre otomatik kaydetsin varmıdır sizce bunun bir kodu yada yöntemi yardımlarınız bekliyorum saygılar

 

[Ömer2134]

Merhaba

Verdiğiniz bu linkte kodları inceledim fakat bir türlü çalıştıramadım.
http://bayramdede.com/outlooktan-excele-mailleri-aktarma/

Option Explicit

Private lRow As Long, x As Date, oWS As Worksheet

Sub GetFromInbox()
    Const olFolderInbox = 6
    Dim olApp As Object, olNs As Object
    Dim oRootFldr As Object
    Dim lCalcMode As Long

    Set olApp = CreateObject("Outlook.Application")
    Set olNs = olApp.GetNamespace("MAPI")
    Set oRootFldr = olNs.GetDefaultFolder(olFolderInbox) '.Folders(InputBox("Maillerin bulunduğu klasörü giriniz", "BDD"))
    Set oWS = ActiveSheet

    x = Date
    lRow = 2
    lCalcMode = Application.Calculation
    Application.Calculation = xlCalculationManual
    'Application.ScreenUpdating = False
    GetFromFolder oRootFldr
   ' Application.ScreenUpdating = True
    Application.Calculation = lCalcMode

    Set oWS = Nothing
    Set oRootFldr = Nothing
    Set olNs = Nothing
    Set olApp = Nothing
End Sub

Private Sub GetFromFolder(oFldr As Object)
    Dim oItem As Object, oSubFldr As Object

    For Each oItem In oFldr.Items
    Range("g1").Value = lRow
        If TypeName(oItem) = "MailItem" Then
            With oItem
'               If .Subject = "Is Goremezlik Raporu" Then
                    oWS.Cells(lRow, 1).Value = .SenderName
                    oWS.Cells(lRow, 2).Value = .to
                    oWS.Cells(lRow, 3).Value = .cc
                    oWS.Cells(lRow, 4).Value = .Subject
                    oWS.Cells(lRow, 5).Value = .ReceivedTime
                    oWS.Cells(lRow, 6).Value = .body
                    lRow = lRow + 1
                   ' If lRow = 10 Then Exit Sub
'                End If
            End With
        End If
    Next

    ' Recurse all Subfolders
    For Each oSubFldr In oFldr.Folders
        GetFromFolder oSubFldr
    Next
End Sub

Ayrıca subfolderdan gelen mailleri nasıl aktarabiliriz.

Teşekkürler.