AW: Kopie von gesendeter Mail
07.12.2010 18:21:53
gesendeter
Hallo,
könnte man so machen, allerdings muss man dem Code so viel Zeit einräumen bis sichergestellt ist
das die Mail versendet ist, hier habe ich mal 30 Sekunden eingestellt.
Wenn man die Sicherheitswarnung abstellen will, verwende ich dies.
http://www.mapilab.com/de/outlook/security/
Du kannst auch mal mit Google suchen, da gibt es noch Versionen mit SendKey.
Private Sub CommandButton1_Click()
Dim strArrayFiles() As String
Dim i As Integer, ii As Integer
With ListBox1
If .ListIndex > -1 Then
Redim Preserve strArrayFiles(.ListCount - 1)
For i = 0 To .ListCount - 1
If .Selected(i) Then
strArrayFiles(ii) = .List(i)
ii = ii + 1
End If
Next i
Redim Preserve strArrayFiles(ii - 1)
Send_Mail strArrayFiles
End If
End With
End Sub
Private Sub Send_Mail(ArrayAnlage() As String)
Dim MyOutApp As Object, MyMessage As Object
Dim varFiles
Set MyOutApp = CreateObject("Outlook.Application")
Set MyMessage = MyOutApp.CreateItem(0)
With MyMessage
.To = "tino@tinomargit.com"
.Subject = "hier der Betreff"
.body = "Mein Text"
For Each varFiles In ArrayAnlage
.Attachments.Add varFiles
Next varFiles
'Zeit evtl. anpassen, bis Mail gesendet ist hier 30 Sekunden ******************************************
Application.OnTime Now + TimeSerial(0, 0, 30), "'Suche_Mail """ & CDbl(Now) & """,""" & .Subject & """'"
.Send 'Hier wird die Mail gesendet
End With
Set MyOutApp = Nothing
Set MyMessage = Nothing
End Sub
In ein Modul kommt dieser Code.
Sub Suche_Mail(vonDatum As Date, strBetreff$)
Dim objOutlook As Object, objNameSpace As Object
Dim objMapiFolder As Object, objItems As Object
Dim bisDatum As Date
Dim SaveAsPath$
SaveAsPath = IIf(Right$(ThisWorkbook.Path, 1) = "\", ThisWorkbook.Path, ThisWorkbook.Path & "\")
Set objOutlook = CreateObject("Outlook.Application")
Set objNameSpace = objOutlook.GetNamespace("MAPI")
Set objMapiFolder = objNameSpace.GetDefaultFolder(5)
Set objItems = objMapiFolder.Items
objItems.Sort "[ReceivedTime]"
objItems.IncludeRecurrences = True
Set objItems = objItems.Restrict("[ReceivedTime] >= '" & Format(vonDatum, "dd.mm.yyyy hh:mm") & "'")
'Schleife durch alle gefundenen Mails
For Each objItems In objItems
With objItems
If .Subject = strBetreff Then
.SaveAs SaveAsPath & .Subject & "_" & Format(Date, "dd_mm_yyyy") & ".msg"
Exit For
End If
End With
Next objItems
Set objNameSpace = Nothing
Set objNameSpace = Nothing
Set objMapiFolder = Nothing
Set objItems = Nothing
End Sub
Gruß Tino