AW: Outlook-Script: Gesendet Emails in anderes Postfach versch.
02.01.2024 21:42:32
Oldie64
@Fennek
Vielen Dank für deine Mühe.
Ich stelle mal hier den derzeit aktuellen Code vom Script ein. Vielleicht kann man ja den entsprechend anpassen. Ob der so umfangreich sein muss, damit nur die gesendeten Emails automatisch in das Archiv-Postfach geordnet nach Jahr und Monat verschoben werden, kann ich nicht beurteilen.
Attribute VB_Name = "Modul1"
Dim Art, Betr, Sender, Empf, Nachr, Jahr, Monat, Nachw, BearbZeit As String, nr, nra As Variant
'******************************************************
'Modul zur Nachweisung der eingehenden Post in Outlook.
'Hierbei wird der Msg eine fortlaufende Nummer gegeben
'und eine Kopie der Nachricht in einem bestimmten
'Verzeichnis abgelegt.
'
'######################################################
'Hinweis: Unter NachwOeffnen und NachwSpeichern befinden sich hardcodierte Verzeichnisse
Sub NachweisenPosteingangOutlook()
'Version 2.1a
'Nachweisung öffnen
NachwOeffnen
If Nachw = "" Then GoTo Fehler 'Wenn das Dateiverzeinis der Nachweisung leer bleibt, dann zur Sprungmarke "fehler"
'Absender prüfen
Absender
If Sender = "" Then GoTo Fehler
'Empfänger prüfen
An
If Empf = "" Then GoTo Fehler
'Betreff prüfen
Betreff
If Betr = "" Then GoTo Fehler
'Bearbeitungszeit feststellen
Zeit
'Nachweisung schließen
NachwSchliessen
'Nachricht abspeichern
NachrSpeichern
'Mitteilung über den Erfolg ausgeben
Meldung
Exit Sub
Fehler:
Close #1
nr = 0
End Sub
'Säubern des Betreffs
'Damit kann der Betreff ohne Sonderzeichen gespeichert werden
Function Betreff()
a = Application.ActiveInspector 'Variable "a" mit der aktuellen Mail füllen
b = a.Subject 'Variable "b" mit dem Betreff der Mail füllen
b = Replace(b, "!", " ") 'Gesucht wird das Zeichen "!" und duch ein Leerzeichen ersetzt
b = Replace(b, "§", " ")
b = Replace(b, "$", " ")
b = Replace(b, "%", " ")
b = Replace(b, "&", " ")
b = Replace(b, "/", " ")
b = Replace(b, "(", " ")
b = Replace(b, ")", " ")
b = Replace(b, "=", " ")
b = Replace(b, "?", " ")
b = Replace(b, "´", " ")
b = Replace(b, "`", " ")
b = Replace(b, "\", " ")
b = Replace(b, "}", " ")
b = Replace(b, "]", " ")
b = Replace(b, "[", " ")
b = Replace(b, "", " ")
b = Replace(b, ">", " ")
b = Replace(b, "|", " ")
b = Replace(b, "µ", " ")
b = Replace(b, ";", " ")
b = Replace(b, ",", " ")
b = Replace(b, ":", " ")
b = Replace(b, ".", " ")
b = Replace(b, "@", "a")
b = Replace(b, "#", " ")
b = Replace(b, "'", " ")
b = Replace(b, "+", " ")
b = Replace(b, "*", " ")
b = Replace(b, "~", " ")
b = Replace(b, "^", " ")
b = Replace(b, "°", " ")
b = Replace(b, "", " ")
b = Replace(b, "®", " ")
b = Replace(b, Chr(34), " ") 'Gesucht wird das ASCII-Zeichen 34 und duch ein Leerzeichen ersetzt
b = Replace(b, Chr(148), " ")
b = Replace(b, Chr(147), " ")
b = Replace(b, Chr(132), " ")
b = Replace(b, Chr(139), " ")
b = Replace(b, Chr(155), " ")
'Betrefflänge ermitteln
c = Len(b) 'Länge(in Zeichen) des Betreffs messen
nra = nr & "-" & Monat & "-" & Right(Jahr, 2) 'Variable "nra" mit fortlaufender Nummer(Variable),Monat, Jahr zweistellig füllen
Select Case c 'Auswahl der Länge des Betreffs
Case Is 5 'Wenn der Betreff der Mail weniger als 5 Zeichen hat, neuen Betreff eintragen
MsgBox ("Bitte aussagekräftigen Betreff eintragen (mehr als 4 Stellen)!" + Chr(13) + Chr(13) & _
"Falls schon ein Betreff eingetragen wurde (Einfügemarke blinkt noch in der Betreff-Zeile)," + Chr(13) + Chr(13) & _
"bitte mit " + Chr(148) + "Eingabe-" + Chr(148) + " oder " + Chr(148) + "Tabulatortaste" + Chr(148) + " abschliessen!" + Chr(13) + Chr(13) & _
"Programm wird abgebrochen!"), vbCritical
Betr = "" 'Variable "betr" leer lassen
Case Is > 180 'Wenn der Betreff mehr als 180 Zeichen hat, einen kürzeren eintragen
MsgBox ("Betreff ist zu lang! Bitte kürzen!" + Chr(13) + Chr(13) & _
"Programm wird abgebrochen!"), vbCritical
Betr = ""
Case Else 'Anderenfalls
If Left(b, 4) = "WG " Then 'Wenn im Betreff von links gesehen die ersten vier Zeichen "WG " lauten
D = Right(b, c - 4): Betr = nra + Chr(32) + Chr(32) + Chr(32) + D: a.Subject = Betr
Betr = D
Else: Betr = nra + Chr(32) + Chr(32) + Chr(32) + b: a.Subject = Betr
Betr = b
End If
End Select
End Function
'Funktion um den Absendernamen zu prüfen
Function Absender()
Dim myfolder As Outlook.MAPIFolder
Dim strname As String
Dim myItem As MailItem
Dim olSelection As Selection
Set myExplorer = Application.ActiveExplorer 'Variable als Explorer initialisieren
Set myfolder = myExplorer.CurrentFolder 'Variable mit aktuellem Dateiordner initialisieren
If Not myfolder.DefaultItemType = olMailItem Then GoTo Ende
Set olSelection = myExplorer.Selection 'Variable mit der aktuellen Explorerauswahl initialisieren
a = Application.ActiveInspector 'Variable "a" mit der aktuellen Msg füllen
b = a.SentOnBehalfOfName 'Variable "b" mit dem Absender der Msg füllen
'Prüfen des Absendernamens
Select Case b 'Wenn sich die Absendenamen geändert haben, dann muss hier die Änderung vorgenommen werden
'allgemeiner Postausgang
Case Is = "L H Post"
For Each myItem In olSelection
Sender = myItem.SenderName
Sender = Replace(Sender, Chr(155), " ")
Sender = Replace(Sender, Chr(34), " ")
Sender = Replace(Sender, Chr(148), " ")
Sender = Replace(Sender, Chr(147), " ")
Sender = Replace(Sender, Chr(132), " ")
Sender = Replace(Sender, Chr(139), " ")
Art = "O" 'Art der Sendung "O"=Out "I"=In
Next
'interne Absender
Case Is = "L H Post SR"
Sender = b 'erkannter Absender wird übernommen
Art = "O"
'kein Absender vorhanden
Case Is = ""
Z = MsgBox("Im Feld " + Chr(148) + "Von..." + Chr(148) + " konnte kein Absender erkannt werden! Bitte Funktion " + Chr(148) + "Namen überprüfen" + Chr(148) + " ausführen!" + Chr(13) + Chr(10) + Chr(10) & _
"Wenn es sich um einen " + Chr(148) + "Ausgang" + Chr(148) + " handelt, bitte eins der SR - Postfächer auswählen!" + Chr(13) + Chr(10) + Chr(10) & _
"Programm wird abgebrochen!", , "Kein Absender!")
Sender = ""
'andere Absender
Case Else
Sender = b
Z = MsgBox("Da im Feld " + Chr(148) + "Von..." + Chr(148) + " weder " + Chr(148) + "L H Post" + Chr(148) + " noch eines der anderen " + Chr(148) + "SR - Postfächer" + Chr(148) + " angegeben wurde, wird von einer sonstigen Post ausgegangen!" + Chr(13) + Chr(10) + Chr(10) & _
"Wenn es sich um eine " + Chr(148) + "Sonstige-Nachricht" + Chr(148) + " handelt bitte " + Chr(148) + "Ja" + Chr(148) + " betätigen!" + Chr(13) + Chr(13) & _
"Wenn es sich um ein " + Chr(148) + "FAX" + Chr(148) + " handelt bitte " + Chr(148) + "Nein" + Chr(148) + " betätigen!" + Chr(13) + Chr(13) & _
"Oder zum Programmabruch auf " + Chr(148) + "Abbrechen" + Chr(148) + " gehen!", vbCritical + 3)
i = Application.ActiveInspector
If Z = 2 Then Sender = "": Exit Function 'kein Absender erkannt, beenden der Funktion
If Z = 6 Then Art = "E": i.Body = "Sonstige-Nachricht" & Chr(13) & i.Body 'kein Absender erkannt, Sontige Nachricht
If Z = 7 Then Art = "F": i.Body = "FAX-Nachricht" & Chr(13) & i.Body 'kein Absender erkannt, Faxnachricht
End Select
Ende: 'Sprungmarke
End Function
'Prüfen auf Empfänger
Function An()
a = Application.ActiveInspector 'Variable "a" mit der aktuellen Msg initialisien
Empf = a.To 'Variable mit dem vorhandenen Empfänger füllen
If Empf = "" Then MsgBox "Es muss mindestens ein Empfänger im Feld An... ausgewählt werden!", vbCritical, "Empfänger fehlt!"
Nachr = a.CC 'Variable "nachr" mit dem Kopieempfänger füllen
End Function
'Nachweis öffnen
Function NachwOeffnen()
a = Date 'Variable mit dem Systemdatum füllen
Jahr = Right(a, 4) 'Variable mit dem Jahr aus dem Systemdatum füllen alternativ: year(date)
Monat = Mid(a, 4, 2) 'Variable mit dem Monat aus dem Systemdatum füllen alternativ: Month(date)
pfad = "Z:\Ein- Ausgangsbuch\" 'Hardcodiertes Verzeichnis
Nachw = pfad & Monat & "-" & Jahr & ".csv" 'Datei zur Erstellung der forlaufenden Nummer
On Error GoTo Ende
'MsgBox falls Datei für Nachweisnummer noch nicht existiert
If Dir(Nachw) = "" Then Z = MsgBox("Nachweisung für den aktuellen Monat nicht vorhanden! " + Chr(13) + Chr(10) + Chr(10) & _
"Bitte prüfen, ob ein Monatswechsel vorliegt." + Chr(13) + Chr(10) + Chr(10) & _
"Mit OK wird eine neue Nachweisung angelegt beginnend mit Nr. 1, ansonsten abbrechen", vbCritical + vbOKCancel)
If Z = 1 Then Open Nachw For Append As #1: nr = 0: Close #1 'notwendig damit Datei angelegt wird wenn nicht vorhanden
If Z = 2 Then Nachw = "": Exit Function
Open Nachw For Input Lock Read As #1 'Öffnen der Datei lesend als Objekt "#1"
While Not EOF(1) 'Solange bis er nicht am Ende des Files ist
Input #1, nr, Art, BearbZeit, Betr, Sender, Empf, Nachr 'Eintragen in die Datei
Wend
nr = nr + 1 'Zähler hochsetzen
Exit Function
Ende:
If Err.Number = 70 Then MsgBox ("Nachweisung ist gerade in Benutzung! Bitte gleich nochmal probieren") Else MsgBox ("Es ist ein Fehler mit der Nachweisung aufgetreten!" + Chr(13) + Chr(13) + "Programm wird beendet!")
Nachw = ""
End Function
'Datei zur Nachweisung schließen
Function NachwSchliessen()
Close #1
Open Nachw For Append As #1
Write #1, nr, Art, BearbZeit, Betr, Sender, Empf, Nachr
Close #1
End Function
Function NachrSpeichern()
a = Application.ActiveInspector
pfad = "Z:\Sicherung Gesendete Emails\" 'Hardcodiertes Verzeichnis
pfad2 = pfad + Monat + "-" + Jahr: pfad3 = Dir(pfad2, vbDirectory)
If Right(pfad2, 7) > pfad3 Then MkDir (pfad2)
dname = pfad2 & "\" & nra & " " & Betr & ".msg"
a.SaveAs dname
End Function
'Varialbe Bearbeitungszeit füllen
Function Zeit()
BearbZeit = Left(Now(), 16) 'Von der aktuellen Zeit links die ersten 16 Zeichen verwenden
End Function
'Abschlussmeldung Erfolg
Function Meldung()
Z = MsgBox("Nachricht wurde erfolgreich in die Nachweisung eingetragen und gespeichert!" + Chr(13) + Chr(10) + Chr(10) & _
"Nachricht kann nun versendet werden bzw. bei Sonstige Nachricht oder FAX " + Chr(13) + Chr(10) + Chr(10) & _
"kann das Fenster ohne Speicherung geschlossen werden!", vbInformation + vbOKOnly)
End Function
Gruß
Oldie64