|
Moin! Also hatte eben mal Pause gemacht und mich kurz dem Problem gewidmet. Unten eine Lösung. Damit sollte das FOrmat also die Tabelle erhalten bleiben.
Der Teile bis zum Erstellen der Nachrichten gilt ohne Einschränkungen (die Werte ggf. noch vorgeben, sonst werden sie ja gelöscht da mit nix überschrieben). Den Rest danach zum Speichern kannst du probieren. Das klappt aber in der Variante nur unter der Bedingung, dass Outlook beim Aufruf geschlossen ist. Ansonsten bleiben die OL Fenster im Hintergrund (warum auch immer) irgendwie bestehen, auch wenn gesendet wurde und sie eigentlich weg sind (kann aber auch hier an dem System liegen). Kannst es ja mal mit offenem Outlook probieren, vllt. geht es da ja. Falls auch nach dem Senden / Löschen der erzeugten Nachrichten der Code noch läuft, einfach Outlook zumachen. Dann beendet der Code. Das Problem ist bei den freien Nachrichten (display ohne true) das man nicht so ohne weiteres erkennen kann, ob sie noch da oder schon weg sind. Habe deshalb die Fenster im System ausgelesen, da ich von ausging, dass die beim Senden geschlossen werden. Anscheind sind sie dann zwar nicht sichtbar aber noch da. Demzufolge wird es eine Endlosschleife. Erst wenn der letzte Ableger von OL (OL slebst oder eine Nachricht) auch zu ist, melden sich die Fenster alle ab. Deshalb oben die Einschränkungen.
Aber lange Rede kurzer Sinn, einfach mal probieren und schauen ob es klappt. Achja, das speichern klappt eigentlich auch. Hatte da vorher aber den POsteingang durchsucht. Ist hier jetzt geändert. 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 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, "<DATUM>", datum)
text = Replace(text, "<UHRZEIT>", zeit)
text = Replace(text, "<ORT>", 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 anzahl = anzahl + 1
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
|