outlook ta excel eki dosyaya kaydetmek

catalinastrap · 18 Şubat 2014

Merhabalar Arkadaşlar,
outlook ta gelen maillere bilgisayar tarihine göre bakıp(güncel için)
konu kısmında "deneme123" yazan maillerin ekini c:\deneme klasörüne kaydetmek istiyorum.

konu hakkında bilgisi olan varmıdır.

catalinastrap · 18 Şubat 2014

bir kod buldum arkadaşlar fakat "olFolder As Outlook.MAPIFolder" kısmı hata veriyor

Public Sub SaveOlAttachments()
Dim isAttachment As Boolean
Dim olFolder As Outlook.MAPIFolder
Dim msg As Outlook.MailItem
Dim att As Outlook.Attachment
Dim fsSaveFolder, sSavePathFS, ssender As String

On Error GoTo crash

fsSaveFolder = "C:\Documents and Settings\user\Desktop\"
isAttachment = False
Set olFolder = Outlook.GetNamespace("MAPI").Folders("...email server...")
Set olFolder = olFolder.Folders("Inbox")
If olFolder Is Nothing Then Exit Sub

For Each msg In olFolder.Items
If UCase(msg.Subject) = "TEST_TEST" Then
If msg.Attachments.Count > 0 Then
While msg.Attachments.Count > 0
sSavePathFS = fsSaveFolder & msg.Attachments(1).FileName
msg.Attachments(1).SaveAsFile sSavePathFS
msg.Attachments(1).Delete
isAttachment = True
Wend
msg.Delete
End If
End If
Next

crash:
If isAttachment = True Then Call findFiles(fsSaveFolder)
End Sub

Murat OSMA · 18 Şubat 2014

Bkz. http://www.excel.web.tr/f48/gelen-kutusundaki-mail-eklerini-indirmek-t116223.html

Murat OSMA · 18 Şubat 2014

Alternatif;

Gelen kutusuna düşen maillerin eki varsa ve bu ekli dosyanın uzantısı "xlsx" ise eki kaydeder.
Kodları Outlook kod sayfasında "ThisOutlookSession" içine kopyalamanız gerekiyor.

Ek'ler bu klasör altına indirelecektir; "c:\dosyalar\"

Kod:

'Ptrsafe yi 64bit outlok kullandığım için deklare ettim. 32 bitlerde gerekmiyor
Private Declare PtrSafe Sub CopyMem Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function ShellExecute Lib "shell32.dll" Alias _
  "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, _
  ByVal lpFile As String, ByVal lpParameters As String, _
  ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

Private WithEvents Items As Outlook.Items

Private Sub Application_Startup()
  Dim Ns As Outlook.Namespace
  Dim Folder As Outlook.MAPIFolder
  Set Ns = Application.GetNamespace("MAPI")
  Set Folder = Ns.GetDefaultFolder(olFolderInbox)
  Set Items = Folder.Items
End Sub

Private Sub Items_ItemAdd(ByVal Item As Object)
     If TypeOf Item Is Outlook.MailItem Then
        PrintAttachments Item
    End If
End Sub

Private Sub PrintAttachments(oMail As Outlook.MailItem)
  On Error Resume Next
  Dim colAtts As Outlook.Attachments
  Dim oAtt As Outlook.Attachment
  Dim sFile As String
  Dim sDirectory As String
  Dim sFileType As String
  sDirectory = "c:\dosyalar\"
  Set colAtts = oMail.Attachments
  If colAtts.Count Then
    For Each oAtt In colAtts
      sFileType = LCase$(Right$(oAtt.Filename, 4))
      Select Case sFileType
      Case "xlsx"
         sFile = sDirectory & oAtt.Filename
        oAtt.SaveAsFile sFile
      End Select
    Next
  End If
End Sub

catalinastrap · 18 Şubat 2014

hocam kod çalışmadı

catalinastrap · 19 Şubat 2014

Murat OSMA' Alıntı:

Alternatif;

Gelen kutusuna düşen maillerin eki varsa ve bu ekli dosyanın uzantısı "xlsx" ise eki kaydeder.
Kodları Outlook kod sayfasında "ThisOutlookSession" içine kopyalamanız gerekiyor.

Ek'ler bu klasör altına indirelecektir; "c:\dosyalar\"

Kod:

'Ptrsafe yi 64bit outlok kullandığım için deklare ettim. 32 bitlerde gerekmiyor
Private Declare PtrSafe Sub CopyMem Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function ShellExecute Lib "shell32.dll" Alias _
  "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, _
  ByVal lpFile As String, ByVal lpParameters As String, _
  ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

Private WithEvents Items As Outlook.Items

Private Sub Application_Startup()
  Dim Ns As Outlook.Namespace
  Dim Folder As Outlook.MAPIFolder
  Set Ns = Application.GetNamespace("MAPI")
  Set Folder = Ns.GetDefaultFolder(olFolderInbox)
  Set Items = Folder.Items
End Sub

Private Sub Items_ItemAdd(ByVal Item As Object)
     If TypeOf Item Is Outlook.MailItem Then
        PrintAttachments Item
    End If
End Sub

Private Sub PrintAttachments(oMail As Outlook.MailItem)
  On Error Resume Next
  Dim colAtts As Outlook.Attachments
  Dim oAtt As Outlook.Attachment
  Dim sFile As String
  Dim sDirectory As String
  Dim sFileType As String
  sDirectory = "c:\dosyalar\"
  Set colAtts = oMail.Attachments
  If colAtts.Count Then
    For Each oAtt In colAtts
      sFileType = LCase$(Right$(oAtt.Filename, 4))
      Select Case sFileType
      Case "xlsx"
         sFile = sDirectory & oAtt.Filename
        oAtt.SaveAsFile sFile
      End Select
    Next
  End If
End Sub

merhaba;
koda konu kısmınıda ekleyebilirmiyiz ?

catalinastrap · 19 Şubat 2014

outlook 2012 kullanıyorum bununla alakalımı kodu çalıştıramadım

Murat OSMA · 19 Şubat 2014

Bilgisayar basina gectigimde yanıtlarım.

catalinastrap · 19 Şubat 2014

Hocam; şöyle bir kod buldum

Sub deneme()

Const olFolderInbox = 6

Set objOutlook = CreateObject("Outlook.Application")
Set objNamespace = objOutlook.GetNamespace("MAPI")
Set objFolder = objNamespace.GetDefaultFolder(olFolderInbox)

Set colItems = objFolder.Items

For Each objMessage In colItems
intCount = objMessage.Attachments.Count
If intCount > 0 Then
For i = 1 To intCount
objMessage.Attachments.Item(i).SaveAsFile "C:\Veri\" & _
objMessage.Attachments.Item(i).FileName
Next
End If
Next

End Sub

tamamını atıyor ancak bana tarihe ve konu kısmında "deneme" yazan şeklinde sorgulayacak ve bu kurallar geçerli ile atacak şekli lazım düzenleyemedim bir türlü

catalinastrap · 19 Şubat 2014

Murat OSMA' Alıntı:
Bilgisayar basina gectigimde yanıtlarım.

tamam hocam;
bekleyeceğim

Murat OSMA · 19 Şubat 2014

Bu kodları bir deneyiniz (Konuya göre );

Kod:

Sub deneme()
    Const olFolderInbox = 6
    Set objOutlook = CreateObject("Outlook.Application")
    Set objNamespace = objOutlook.GetNamespace("MAPI")
    Set objFolder = objNamespace.GetDefaultFolder(olFolderInbox)
    Set colItems = objFolder.Items
    For Each objMessage In colItems
        If objMessage.Subject = "[COLOR="Red"]Buraya konuyu yazın[/COLOR]" Then
            intCount = objMessage.Attachments.Count
            If intCount > 0 Then
                For i = 1 To intCount
                    objMessage.Attachments.Item(i).SaveAsFile "C:\Veri\" & _
                    objMessage.Attachments.Item(i).FileName
                Next i
            End If
        End If
    Next objMessage
End Sub

catalinastrap · 19 Şubat 2014

Murat OSMA' Alıntı:

Bu kodları bir deneyiniz (Konuya göre );

Kod:

Sub deneme()
    Const olFolderInbox = 6
    Set objOutlook = CreateObject("Outlook.Application")
    Set objNamespace = objOutlook.GetNamespace("MAPI")
    Set objFolder = objNamespace.GetDefaultFolder(olFolderInbox)
    Set colItems = objFolder.Items
    For Each objMessage In colItems
        If objMessage.Subject = "[COLOR="Red"]Buraya konuyu yazın[/COLOR]" Then
            intCount = objMessage.Attachments.Count
            If intCount > 0 Then
                For i = 1 To intCount
                    objMessage.Attachments.Item(i).SaveAsFile "C:\Veri\" & _
                    objMessage.Attachments.Item(i).FileName
                Next i
            End If
        End If
    Next objMessage
End Sub

Budur Hocam,
ellerine kollarına sağlık çooooook teşekkür ederim.

Murat OSMA · 19 Şubat 2014

Rica ederim, iyi günler.

catalinastrap · 19 Şubat 2014

Hocam Çok Oldum Biliyorum ama,
sadece excel olanları al diyebilirmiyiz.
imzalarda bulunan jpg ve gif leride atıyo şimdi farkettim

Murat OSMA · 19 Şubat 2014

Disaridayim şu an ama önceki mesajlarımda bitler bir şart vardı sanki xlsx olarak bir bakarsaniz kendinize göre uyarlayabilirsiniz.

Murat OSMA · 19 Şubat 2014

Bu kodları kullanabilirsiniz;

Kod:

Sub deneme()
    Const olFolderInbox = 6
    Set objOutlook = CreateObject("Outlook.Application")
    Set objNamespace = objOutlook.GetNamespace("MAPI")
    Set objFolder = objNamespace.GetDefaultFolder(olFolderInbox)
    Set colItems = objFolder.Items
    For Each objMessage In colItems
        If objMessage.Subject = "Buraya konuyu yazın" Then
            intCount = objMessage.Attachments.Count
            If intCount > 0 Then
                For i = 1 To intCount
                    dosya = objMessage.Attachments.Item(i).Filename
                    c = Split(dosya, ".")(1)
                    If c = "xlsx" Or c = "xlsm" Or c = "xls" Then
                        objMessage.Attachments.Item(i).SaveAsFile "C:\Veri\" & dosya
                    End If
                Next i
            End If
        End If
    Next objMessage
    Set objOutlook = Nothing: Set objNamespace = Nothing: Set objFolder = Nothing
    Set colItems = Nothing: Set objMessage = Nothing: intCount = Empty: i = Empty
End Sub

catalinastrap · 20 Şubat 2014

Murat Hocam;
tarih kontrolü koyabilirmiyiz mesela son 5 gün gelen mesajların içinde koşullar çalışsın
eski maillere bakmasın

Murat OSMA · 20 Şubat 2014

Bu şekilde bir deneyinix;

Kod:

Sub deneme()
    Const olFolderInbox = 6
    Set objOutlook = CreateObject("Outlook.Application")
    Set objNamespace = objOutlook.GetNamespace("MAPI")
    Set objFolder = objNamespace.GetDefaultFolder(olFolderInbox)
    Set colItems = objFolder.items
    On Error Resume Next
    For Each objMessage In colItems
        DoEvents
        [COLOR="Red"]If objMessage.ReceivedTime >= Now - 5 And objMessage.ReceivedTime <= Now Then
        If Err Then Err.Clear: GoTo a[/COLOR]
        If objMessage.Subject = "Buraya konuyu yazın" Then
            intCount = objMessage.Attachments.Count
            If intCount > 0 Then
                For i = 1 To intCount
                    dosya = objMessage.Attachments.Item(i).Filename
                    c = Split(dosya, ".")(1)
                    If c = "xlsx" Or c = "xlsm" Or c = "xls" Then
                        objMessage.Attachments.Item(i).SaveAsFile "C:\Veri\" & dosya
                    End If
                Next i
            End If
        End If
        End If
[COLOR="red"]a:[/COLOR]    Next objMessage
    Set objOutlook = Nothing: Set objNamespace = Nothing: Set objFolder = Nothing
    Set colItems = Nothing: Set objMessage = Nothing: intCount = Empty: i = Empty
End Sub

catalinastrap · 20 Şubat 2014

teşekkür

Hocam elleriniz dert görmesin süpersiniz valla nediim

Murat OSMA · 20 Şubat 2014

Eksik olmayın...

İyi günler.

outlook ta excel eki dosyaya kaydetmek

Özgür ALTAY

Özgür ALTAY

Altın Üye

Altın Üye

Özgür ALTAY

Özgür ALTAY

Özgür ALTAY

Altın Üye

Özgür ALTAY

Özgür ALTAY

Altın Üye

Özgür ALTAY

Altın Üye

Özgür ALTAY

Altın Üye

Altın Üye

Özgür ALTAY

Altın Üye

Özgür ALTAY

Altın Üye