EMail Anhänge letzte Email speichern

Hallo alle zusammen,
ich habe eine Frage hinsichtlich dem Speichern von Email Anhängen. Ich verwende Outlook und habe derzeit einen Code am laufen, der mir Emails der letzten 30 min nach einem Betreff durchsucht und Anlagen daraus abspeichert. Leider macht er nur pdfs.
Ich würde den Code gerne umschreiben und zwar dahingehend, dass nur die letzte Email nach Anhängen durchsucht wird. Hierbei soll auch die Dateiendung keine rolle spielen. Der Code soll anschließend die Datei umbenennen und in einem Ordner abspeichern. Könnte mir vl. jemand beim Modifizieren ein bisschen unter die Arme greifen? lieben dank


Private Sub CommandButton12_Click()
'Button zum Import Email-Anhängen aus letzter Email
Dim olApp As Object
Dim objFolder As Object
Dim objItem As Object
Dim zeit As String
Dim counter As Long
dim spfadscan as string
If MsgBox("Möchten Sie aus Ihrem persönlichen Email-Posteingang den Anhangsimport starten?" , vbQuestion + vbYesNo, "Anhang import") = vbYes Then
Set olApp = CreateObject("outlook.application")
Set objFolder = olApp.GetNamespace("MAPI").GetDefaultFolder(6)
zeit = DateAdd("n", -30, Now())   ' 30 Minuten
counter = 1
spfadscan ="X:\Scan"
For Each objItem In objFolder.Items
If CDate(objItem.receivedtime()) >= zeit Then
If objItem.Subject Like "*" & "Scan" & "*" Then
If objItem.attachments.Count > 0 Then
With objItem.attachments.Item(1)
If .Filename Like "*.pdf" Then
.SaveAsFile sPfadScan & Format(Now(), "yyyy-mm-dd") & "_" & Format(Now(), "hh-mm-ss") & "_" & "Import" & ".pdf"
End If
End With
Else
End If
objItem.Delete
counter = counter + 1
Else
End If
End If
Next
Set objFolder = Nothing
Set olApp = Nothing
End If
End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub findNewestMail() Dim olApp As Object Dim objFolder As Object Dim objItem As Object Dim ze As Long Dim vNewest As Date Set olApp = CreateObject("outlook.application") Set objFolder = olApp.GetNamespace("MAPI").GetDefaultFolder(6) With Sheets("HT") For Each objItem In objFolder.Items If objItem.attachments.Count > 0 Then ze = ze + 1 .Cells(ze, 1) = objItem .Cells(ze, 2) = objItem.ReceivedTime .Cells(ze, 3) = ze End If Next Set objFolder = Nothing Set olApp = Nothing 'die Variable vNewest ist dann die neueste '(jüngste) Email mit Attachemant vNewest = CDate(WorksheetFunction.Max(.Range("B1:B" _ & .Cells(Rows.Count).End(xlUp).Row))) MsgBox vNewest End With End Sub

Sub findNewestMail() Dim olApp As Object Dim objFolder As Object Dim objItem As Object Set olApp = CreateObject("outlook.application") Set objFolder = olApp.GetNamespace("MAPI").GetDefaultFolder(6) Dim objSortedList As Object, objArrayList As Object Set objSortedList = CreateObject("System.Collections.SortedList") Set objArrayList = CreateObject("System.Collections.ArrayList") Dim vNewest As Date For Each objItem In objFolder.Items If objItem.attachments.Count > 0 Then If objItem.attachments.Count > 0 Then objArrayList.Add objItem.ReceivedTime End If End If Next vNewest = objArrayList(0) MsgBox "Zeit des jüngsten Mail-Eingangs: " & vbCr & vbCr & vbTab & vNewest Set objSortedList = Nothing Set objArrayList = Nothing End Sub

Sub findNewestMail() Dim olApp As Object Dim objFolder As Object Dim objItem As Object Set olApp = CreateObject("outlook.application") Set objFolder = olApp.GetNamespace("MAPI").GetDefaultFolder(6) Dim objSortedList As Object, objArrayList As Object Set objSortedList = CreateObject("System.Collections.SortedList") Set objArrayList = CreateObject("System.Collections.ArrayList") Dim vNewest As Date For Each objItem In objFolder.Items If objItem.attachments.Count > 0 Then objArrayList.Add objItem.ReceivedTime End If Next vNewest = objArrayList(0) MsgBox "Zeit des jüngsten Mail-Eingangs: " & vbCr & vbCr & vbTab & vNewest Set objSortedList = Nothing Set objArrayList = Nothing End Sub

Sub findNewestMail() Dim olApp As Object Dim objFolder As Object Dim objItem As Object Set olApp = CreateObject("outlook.application") Set objFolder = olApp.GetNamespace("MAPI").GetDefaultFolder(6) Dim objSortedList As Object, objArrayList As Object Set objSortedList = CreateObject("System.Collections.SortedList") Set objArrayList = CreateObject("System.Collections.ArrayList") Dim vNewest As Date For Each objItem In objFolder.Items If objItem.attachments.Count > 0 Then objArrayList.Add objItem.ReceivedTime End If Next Call objArrayList.AddRange(c:=objSortedList.GetKeyList()) ' nur zum Testen in eine vorhandene Tabelle "HT" ausgeben 'For ze = 0 To objArrayList.Count - 1 ' Sheets("HT").Range("A" & ze + 1) = objArrayList(ze) 'Next 'zu verwenden für die neueste Mail: vNewest = objArrayList(0) MsgBox "Zeit des jüngsten Mail-Eingangs: " & vbCr & vbCr & vbTab & vNewest Set objSortedList = Nothing Set objArrayList = Nothing End Sub

Sub TestSort() Dim coll As New Collection Dim olApp As Object Dim objFolder As Object Dim objItem As Object Set olApp = CreateObject("outlook.application") Set objFolder = olApp.GetNamespace("MAPI").GetDefaultFolder(6) Dim objSortedList As Object, objArrayList As Object Set objSortedList = CreateObject("System.Collections.SortedList") Set objArrayList = CreateObject("System.Collections.ArrayList") Dim vNewest As Date For Each objItem In objFolder.Items If objItem.attachments.Count > 0 Then coll.Add objItem.ReceivedTime End If Next QuickSort coll, 1, coll.Count vNewest = coll(1) 'zur Überprüfung im Direktbereich ausgeben 'Dim v As Variant 'For Each v In coll ' Debug.Print v 'Next End Sub Sub QuickSort(coll As Collection, first As Long, last As Long) Dim vCentreVal As Variant, vTemp As Variant Dim lTempLow As Long Dim lTempHi As Long lTempLow = first lTempHi = last vCentreVal = coll((first + last) \ 2) Do While lTempLow first lTempHi = lTempHi - 1 Loop If lTempLow

Option Explicit Sub Newest_and_oldest_Mail_with_Attachement() Dim olApp As Object, objArrayList As Object, objFolder As Object, objItem As Object Dim vNewest As Date, vOldest As Date Dim temp As Date, i As Long, j As Long, ze As Long Set olApp = CreateObject("outlook.application") Set objFolder = olApp.GetNamespace("MAPI").GetDefaultFolder(6) Set objArrayList = CreateObject("System.Collections.ArrayList") 'Emaileingänge mit Anhang in Array schreiben For Each objItem In objFolder.Items If objItem.attachments.Count > 0 Then objArrayList.Add objItem.ReceivedTime End If Next 'Array sortieren For i = objArrayList.Count To 0 Step -1 For j = i - 1 To 0 Step -1 If objArrayList(i - 1) > objArrayList(j) Then temp = objArrayList(j) objArrayList(j) = objArrayList(i - 1) objArrayList(i - 1) = temp End If Next Next 'Älteste und neueste Mail Eingangszeit ausgeben vNewest = objArrayList(0) vOldest = objArrayList(objArrayList.Count - 1) MsgBox "Älteste Mail mit Anhang vom: " & vbTab & vOldest & vbCr & _ "Neueste Mail mit Anhang vom: " & vbTab & vNewest, vbInformation, "Älteste und Neueste Mail" ' nur zum Testen in eine vorhandene Tabelle "HT" ausgeben 'For ze = 0 To objArrayList.Count - 1 ' Sheets("HT").Range("A" & ze + 1) = objArrayList(ze) 'Next Set objArrayList = Nothing Set objFolder = Nothing Set olApp = Nothing End Sub

For Each objItem In objFolder.Items If objItem.ReceivedTime = vNewest Then With objItem.attachments.Item(1) If .Filename Like "*.txt" Then .SaveAsFile "C:\Users\joche\Downloads\" & _ objItem.attachments.Item(1).Filename End If End With End If Next

Beliebteste Forumthreads (12 Monate)

EMail Anhänge letzte Email speichern

15
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

156 Forumthreads zu ähnlichen Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

EMail Anhänge letzte Email speichern

15 Beiträge zum Forumthread Beiträge zu diesem Forumthread

156 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

15
Beiträge zum Forumthread

Beiträge zu diesem Forumthread