Da kam mir eben noch ein schlauer Gedanke. :-) Die Version hier sollte auch bei laufendem OL gehen. Hat zumindest in mehrern Durchläufen geklappt. Hoffe mal ich posten den richtigen Code. Teste da grad in 3 Modulen und ist schon ziemlich früh. :-) Das Programm schaut jetzt halt noch, ob die OL Ableger auch sichtbar sind. DAmit scheiden die "ausgeblendeten" aus und man kommt zu einem Ende. Auch wieder probieren, OL darf dabei an sein. VG

Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wCmd As Long) As Long
Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Declare Function IsWindowVisible Lib "user32" (ByVal hwnd As Long) As Long
Private Const GW_CHILD = 5
Private Const GW_HWNDNEXT = 2
 
Sub mail_aus_vorlage()
Dim outlook As Object
Dim neueNachricht As Object
Dim betreff As String
Dim text As String
Dim pfad1 As String, pfad2 As String, pfad3 As String, speicherpfad As String
Dim I As Long
Dim datum, zeit, ort
Dim ekonto
Dim nachricht
Dim inbox
Dim zahler
Dim pfad(3)
'für das prüfen auf Versand
Dim handle As Long
Dim RetVal1 As Long
Dim RetVal2 As Long
Dim textclass As String
Dim textname As String
Dim anzahl As Long
   
pfad(1) = "Pfad der ersten Vorlage mit Name auf .oft"
pfad(2) = "Pfad der zweiten Vorlage mit Name auf .oft"
pfad(3) = "Pfad der dritten Vorlage mit Name auf .oft"
speicherpfad = "Pfad zum Abspeichern endet mt \"
   
'userform1.Show
'datum = userform1.textbox1
'zeit = userform1.textbox2
'ort = userform1.textbox3
'Unload userform1
  
Set outlook = CreateObject("Outlook.Application")
'hier den eigenen pfad reinpacken, dateiname endet mit .oft
   
For I = 1 To 3
    Set neueNachricht = outlook.CreateItemFromTemplate(pfad(I))
    'alten Betreff und Text auslesen - ggf. zugriff erlauben
    betreff = neueNachricht.Subject
    text = neueNachricht.body
    'Betreff um Datum ergänzen
    betreff = Format(datum, "yyyymmdd") & betreff
    neueNachricht.Subject = betreff
    ' Text ändern und ersetzen
    Select Case neueNachricht.bodyformat
         
        Case 1 'nur Text
            text = neueNachricht.body
            text = Replace(text, "<DATUM>", datum)
            text = Replace(text, "<UHRZEIT>", zeit)
            text = Replace(text, "<ORT>", ort)
            neueNachricht.body = text
             
        Case 2 'htmlMail mit Tabellen
            text = neueNachricht.htmlbody
            text = Replace(text, "&lt;DATUM&gt;", datum)
            text = Replace(text, "&lt;UHRZEIT&gt;", zeit)
            text = Replace(text, "&lt;ORT&gt;", ort)
            neueNachricht.htmlbody = text
     
        Case Else 'falls ein Fehler kam, RichText wäre 3 und unspecified die 0
         
    End Select
    
    neueNachricht.display True
    Set neueNachricht = Nothing
Next I
   
'prüfen, ob die Mails verschickt wurden, dazu einfach die Fenster abfragen nd schauen, ob es noch eine Nachricht gibt
 
anzahl = 3
While anzahl <> 0
    anzahl = 0
    handle = GetDesktopWindow()
    handle = GetWindow(handle, GW_CHILD)
    Do While handle <> 0
 
        textclass = String(255, 0)
        RetVal = GetClassName(handle, textclass, Len(textclass))
            If Mid(textclass, 1, RetVal) = "rctrl_renwnd32" Then
                textname = String(255, 0)
                RetVal2 = GetWindowText(handle, textname, Len(textname))
                textxname = Mid(textname, 1, RetVal2)
                If Left(textname, 8) = Format(datum, "yyyymmdd") And InStr(1, textname, "- Nachricht (", vbTextCompare) > 0 Then
                    If IsWindowVisible(handle) Then
                        anzahl = anzahl + 1
                    End If
                End If
            End If
        handle = GetWindow(handle, GW_HWNDNEXT)
        DoEvents
    Loop
Wend
 
 
'Mails sollten weg sein, also speichern
zahler = 0
Set outlook = CreateObject("Outlook.Application")
Set ekonto = outlook.GetNamespace("MAPI")
Set inbox = ekonto.GetDefaultFolder(5)  'der Posteingang
   
For Each nachricht In inbox.items   'alle Mails durchgehen
    If zahler < 4 Then  'um nur die ersten drei Treffer zu speichern
        If Left(nachricht.Subject, 8) = Format(datum, "yyyymmdd") Then  'wenn der Betreff damit beginnt
            nachricht.SaveAs speicherpfad & nachricht.Subject & ".msg"
            zahler = zahler + 1  'dadurch werden nur die ersten 3 Treffer gespeichert
        End If
    End If
Next nachricht
                   
                 
End Sub