ich habe endlich einen Code gebastelt, der die geforderten Aufgaben erfüllt.
Die Experten finden sicher noch Optimierungspotential. Ich bin dankbar für Eure Tipps
Ich habe zwei Userforms erstellt, eine für die Adressaten, eine für die Kontrolle.
Aus dem Userform Kontroll heraus wird eine E-Mail versandt und das gesendet Item
mit der Item.GetFirst-Methode abgspeichert.
Code:
Sub Postnachweis()
Dim oexcel As Object
Dim ws As Object
Dim wb As Object
Dim objMail As MailItem
Dim Auswahl As Selection
Dim dateiname As String
Dim letztezeile As Long
Dim lfn As Long
Dim newmail As Object
Dim olVerz As Outlook.MAPIFolder, olSubVerz1 As Outlook.MAPIFolder, olSubVerz2 As Outlook.MAPIFolder
For Each objMail In Outlook.ActiveExplorer.Selection
'Prüfung ob mehr als eine Mail markierte wurde
'Programmabbruch wenn mehr als eine Mail markiert wurde
Set Auswahl = Outlook.ActiveExplorer.Selection
If Auswahl.Count > 1 Then
MsgBox ("Sie haben zu viele E-Mails ausgewählt." & vbLf & vbLf & "Bitte markieren Sie nur eine E-Mail."), vbCritical
Exit Sub
End If
dateiname = "XXXXXXXXXXXXXXXXXXXXXXXXXXXXX" & x & ".xlsx" 'ggfs anpassen '!!!!!!!!!!!!!!!!!!!!!!!!!!!
'Öffnen der Excel-Datei
On Error Resume Next
Set oexcel = GetObject("excel.application")
On Error GoTo 0
If oexcel Is Nothing Then Set oexcel = CreateObject("Excel.Application")
Set wb = oexcel.Workbooks.Open(dateiname)
If wb.ReadOnly = True Then
GoTo DateiOffen:
End If
Set ws = wb.Sheets(1)
'Letzte beschriebene Zeile in Excel-Datei ermitteln
'On Error GoTo KeineVerweise:
ws.Activate
letztezeile = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
If letztezeile = 1 Then
lfn = 1
End If
If lfn = 1 Then
lfn = 1
lfn2 = 2
Else
lfn2 = letztezeile + 1
lfn = letztezeile
End If
'Erstellen der Daten für die Userform
Empfaenger.Show
'Empfänger
'Werden weitere Empfänger in der Userform 2 hinzugefügt, müssen
'nachfolgende If-Abfragen erweitert werden
'Muster:
'If UserForm2.CheckBoxX = True Then
'empfX = UserForm2.CheckBoxX.Caption
'Else: empfX = ""
'End If
' Userform Adressaten Gruppenfeld: Nach Absender---------------------------------------
If Empfaenger.absCheckBox1 = True Then
anabsempf = CStr(Empfaenger.anCheckBox3.Caption & " ")
Else: anabsempf1 = ""
End If
If Empfaenger.absCheckBox2 = True Then
anabsempf = CStr(Empfaenger.anCheckBox2.Caption & " ")
ccabsempf = CStr(Empfaenger.anCheckBox3.Caption & " ")
Else: anabsempf1 = ""
End If
If Empfaenger.absCheckBox3 = True Then
anabsempf = CStr(Empfaenger.anCheckBox5.Caption & " ")
Else: anabsempf1 = ""
End If
If Empfaenger.absCheckBox4 = True Then
anabsempf = CStr(Empfaenger.anCheckBox4.Caption & " ")
Else: anabsempf1 = ""
End If
'Userform Adressaten Gruppenfeld An:-------------------------------------------------
If Empfaenger.anCheckBox1 = True Then
anempf1 = CStr(Empfaenger.anCheckBox1.Caption & " ")
Else: anempf1 = ""
End If
If Empfaenger.anCheckBox2 = True Then
anempf2 = CStr(Empfaenger.anCheckBox2.Caption & " ")
Else: anempf2 = ""
End If
If Empfaenger.anCheckBox3 = True Then
anempf3 = CStr(Empfaenger.anCheckBox3.Caption & " ")
Else: anempf3 = ""
End If
If Empfaenger.anCheckBox4 = True Then
anempf4 = CStr(Empfaenger.anCheckBox4.Caption & " ")
Else: anempf4 = ""
End If
If Empfaenger.anCheckBox5 = True Then
anempf5 = CStr(Empfaenger.anCheckBox5.Caption & " ")
Else: anempf5 = ""
End If
If Empfaenger.anCheckBox6 = True Then
anempf6 = CStr(Empfaenger.anCheckBox6.Caption & " ")
Else: anempf6 = ""
End If
If Empfaenger.anCheckBox7 = True Then
anempf7 = CStr(Empfaenger.anCheckBox7.Caption & " ")
Else: anempf7 = ""
End If
If Empfaenger.anCheckBox8 = True Then
anempf8 = CStr(Empfaenger.anCheckBox8.Caption & " ")
Else: anempf8 = ""
End If
If Empfaenger.anCheckBox9 = True Then
anempf9 = CStr(Empfaenger.anCheckBox9.Caption & " ")
Else: anempf9 = ""
End If
If Empfaenger.anCheckBox10 = True Then
anempf10 = CStr(Empfaenger.anCheckBox10.Caption & " ")
Else: anempf10 = ""
End If
If Empfaenger.anCheckBox11 = True Then
anempf11 = CStr(Empfaenger.anCheckBox11.Caption & " ")
Else: anempf11 = ""
End If
If Empfaenger.anCheckBox12 = True Then
anempf12 = CStr(Empfaenger.anCheckBox12.Caption & " ")
Else: anempf12 = ""
End If
If Empfaenger.anCheckBox13 = True Then
anempf13 = CStr(Empfaenger.anCheckBox13.Caption & " ")
Else: anempf13 = ""
End If
If Empfaenger.anCheckBox14 = True Then
anempf14 = CStr(Empfaenger.anCheckBox14.Caption & " ")
Else: anempf14 = ""
End If
If Empfaenger.anCheckBox15 = True Then
anempf15 = CStr(Empfaenger.anCheckBox15.Caption & " ")
Else: anempf15 = ""
End If
If Empfaenger.anCheckBox16 = True Then
anempf16 = CStr(Empfaenger.anCheckBox16.Caption & " ")
Else: anempf16 = ""
End If
If Empfaenger.anCheckBox17 = True Then
anempf17 = CStr(Empfaenger.anCheckBox16.Caption & " ")
Else: anempf17 = ""
End If
'____________________________________________________________________________
If Empfaenger.anTextBox1 <> "" Then
anempf18 = CStr(Empfaenger.anTextBox1.Value & " ")
Else: anempf18 = ""
End If
anempf = anempf1 & anempf2 & anempf3 & anempf4 & anempf5 & anempf6 & anempf7 & anempf8 & anempf9 & anempf10 & anempf11 & anempf12 & anempf13 & anempf14 & anempf15 & anempf16 & anempf17 & anempf18
bea = Empfaenger.TextBox2.Value
'Userform Adressaten Gruppenfeld Cc:----------------------
If Empfaenger.ccCheckBox1 = True Then
ccempf1 = CStr(Empfaenger.ccCheckBox1.Caption & " ")
Else: ccempf1 = ""
End If
If Empfaenger.ccCheckBox2 = True Then
ccempf2 = CStr(Empfaenger.ccCheckBox2.Caption & " ")
Else: ccempf2 = ""
End If
If Empfaenger.ccCheckBox3 = True Then
ccempf3 = CStr(Empfaenger.ccCheckBox3.Caption & " ")
Else: ccempf3 = ""
End If
If Empfaenger.ccCheckBox4 = True Then
ccempf4 = CStr(Empfaenger.ccCheckBox4.Caption & " ")
Else: ccempf4 = ""
End If
If Empfaenger.ccCheckBox5 = True Then
ccempf5 = CStr(Empfaenger.ccCheckBox5.Caption & " ")
Else: ccempf5 = ""
End If
If Empfaenger.ccCheckBox6 = True Then
ccempf6 = CStr(Empfaenger.ccCheckBox6.Caption & " ")
Else: ccempf6 = ""
End If
If Empfaenger.ccCheckBox7 = True Then
ccempf7 = CStr(Empfaenger.ccCheckBox7.Caption & " ")
Else: ccempf7 = ""
End If
If Empfaenger.ccCheckBox8 = True Then
ccempf8 = CStr(Empfaenger.ccCheckBox8.Caption & " ")
Else: ccempf8 = ""
End If
If Empfaenger.ccCheckBox9 = True Then
ccempf9 = CStr(Empfaenger.ccCheckBox9.Caption & " ")
Else: ccempf9 = ""
End If
If Empfaenger.ccCheckBox10 = True Then
ccempf10 = CStr(Empfaenger.ccCheckBox10.Caption & " ")
Else: ccempf10 = ""
End If
If Empfaenger.ccCheckBox11 = True Then
ccempf11 = CStr(Empfaenger.ccCheckBox11.Caption & " ")
Else: ccempf11 = ""
End If
If Empfaenger.ccCheckBox12 = True Then
ccempf12 = CStr(Empfaenger.ccCheckBox12.Caption & " ")
Else: ccempf12 = ""
End If
If Empfaenger.ccCheckBox13 = True Then
ccempf13 = CStr(Empfaenger.ccCheckBox13.Caption & " ")
Else: ccempf13 = ""
End If
If Empfaenger.ccCheckBox14 = True Then
ccempf14 = CStr(Empfaenger.ccCheckBox14.Caption & " ")
Else: ccempf14 = ""
End If
If Empfaenger.ccCheckBox15 = True Then
ccempf15 = CStr(Empfaenger.ccCheckBox15.Caption & " ")
Else: ccempf15 = ""
End If
If Empfaenger.ccCheckBox16 = True Then
ccempf16 = CStr(Empfaenger.ccCheckBox16.Caption & " ")
Else: ccempf16 = ""
End If
If Empfaenger.ccCheckBox17 = True Then
ccempf17 = CStr(Empfaenger.ccCheckBox17.Caption & " ")
Else: ccempf17 = ""
End If
ccempf = ccempf1 & ccempf2 & ccempf3 & ccempf4 & ccempf5 & ccempf6 & ccempf7 & ccempf8 & ccempf9 & cempf10 & ccempf11 & ccempf12 & ccempf13 & ccempf14 & ccempf15 & ccempf16 & ccempf17 & ccempf18
'bea = Empfaenger.TextBox2.Value
With objMail
Kontrolle.TextBox1 = Format(lfn, "00000")
Kontrolle.TextBox2 = Format(objMail.ReceivedTime, "dd.mm.yyyy")
Kontrolle.TextBox3 = Format(objMail.ReceivedTime, "hh:mm")
Kontrolle.TextBox4 = objMail.SentOnBehalfOfName
Kontrolle.TextBox5 = Format(objMail.ReceivedTime, "yy-mm-dd") & " " & objMail.Subject
Kontrolle.TextBox6 = anempf & anabsempf
Kontrolle.TextBox7 = Format(Date, "dd.mm.yyyy")
Kontrolle.TextBox8 = Format(Time, "hh:mm")
Kontrolle.TextBox9 = bea
Kontrolle.TextBox5 = Replace(Kontrolle.TextBox5, ":", "")
Kontrolle.TextBox5 = Replace(Kontrolle.TextBox5, "/", "")
Kontrolle.TextBox5 = Replace(Kontrolle.TextBox5, "\", "")
Kontrolle.TextBox5 = Replace(Kontrolle.TextBox5, "*", "")
Kontrolle.TextBox5 = Replace(Kontrolle.TextBox5, "?", "")
Kontrolle.TextBox5 = Replace(Kontrolle.TextBox5, "<", "")
Kontrolle.TextBox5 = Replace(Kontrolle.TextBox5, ">", "")
Kontrolle.TextBox5 = Replace(Kontrolle.TextBox5, "|", "")
End With
Next objMail
'Prüfung der Zeilelänge---------------------------
maxzeichen = 90
Zeichenlaenge = Len(Kontrolle.TextBox5)
Kontrolle.Label10.Caption = "Die maximale Länge des Betreffs beträgt " & maxzeichen & "!" & vbLf & _
"Der Betreff ist " & Zeichenlaenge & " Zeichen lang."
If Zeichenlaenge > maxzeichen Then
Kontrolle.Label10.ForeColor = RGB(255, 69, 0)
MsgBox ("Bitte kürzen sie den Betreff!")
Kontrolle.CommandButton1.Enabled = False
Else
Kontrolle.Label10.ForeColor = RGB(46, 139, 87)
Kontrolle.CommandButton1.Enabled = True
End If
____________________________________________________________________-
Kontrolle.Show
'Übergabe der Daten in die Execl-Liste-----------------------------
ws.Activate
ws.Cells(lfn2, 1) = Kontrolle.TextBox1 ' laufende Nummer
ws.Cells(lfn2, 2) = Kontrolle.TextBox2 ' Datum
ws.Cells(lfn2, 3) = Kontrolle.TextBox3 ' Uhrzeit
ws.Cells(lfn2, 4) = Kontrolle.TextBox4 ' Absender
ws.Cells(lfn2, 5) = Kontrolle.TextBox5 ' Betreff
ws.Cells(lfn2, 6) = Kontrolle.TextBox6 ' Empfänger
ws.Cells(lfn2, 7) = Kontrolle.TextBox7 ' Datum
ws.Cells(lfn2, 8) = Kontrolle.TextBox8 ' Uhrzeit
ws.Cells(lfn2, 9) = Kontrolle.TextBox9 ' Bearbeiter
ws.Range("A:I").Columns.AutoFit
'Rahmen um Zelle------------------------------------------------
For Spalte = 1 To 9
ws.Cells(lfn2, Spalte).BorderAround ColorIndex:=1, Weight:=xlThin
Next Spalte
----------------------------------------------------------------
oexcel.activeworkbook.Save
oexcel.Visible = False
-----------------------------------------------------------------
'Sicherungskopie als pdf
With oexcel.activeworkbook.ActiveSheet.PageSetup
Zoom = False
.Orientation = xlLandscape
.FitToPagesWide = 1
End With
oexcel.activeworkbook.ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, filename:= _
"...\Postnachweis_Sicherung.pdf", Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False '!!!
'Excel beenden-------------------------------
oexcel.activeworkbook.Close savechanges:=True
'________________________________________________________
'Versandte E-MAil aus dem Postfach "Gesendete Objekte" speichern
For Each olVerz In Outlook.GetNamespace("Mapi").Folders
If olVerz.Name = "...." Then '!!!
Set olSubVerz1 = olVerz
Exit For
End If
Next olVerz
If Not olSubVerz1 Is Nothing Then
For Each olVerz In olSubVerz1.Folders
If olVerz.Name = "Gesendete Objekte" Then
Set olSubVerz2 = olVerz
Exit For
End If
Next olVerz
End If
If Not olSubVerz2 Is Nothing Then
'MsgBox olSubVerz1.Name & " - " & olSubVerz2.Name & " - " & olSubVerz2.Items.Count 'Testzweck
'MsgBox olSubVerz2.Items.GetFirst.Subject ' Testzweck
'MsgBox olSubVerz2.Items.GetFirst.Format(Now, "YY_MM_DD_HH_MM") & Subject
olSubVerz2.Items.GetFirst.SaveAs "XXXXXXXXXX\Sicherung\" & Kontrolle.TextBox5 & ".msg ", olMSG '!!
Else
MsgBox "kein Postfach bzw. Postfach-Ordner gefunden!", vbCritical Or vbSystemModal
Exit Sub
End If
Set olSubVerz2 = Nothing
Set olSubVerz1 = Nothing
Set olVerz = Nothing
MsgBox "Das elektronische Postbuch wurde ausgefüllt." & vbLf & _
"Eine Sicherungskopie im pdf-Format wurde angelegt." & vbLf & _
"Die versandte E-Mail wurde gesichert."
Unload Empfaenger
Unload Kontrolle
Exit Sub
'Fehlerbehandlung----------------------
KeineVerweise:
MsgBox "Bitte prüfen Sie ob der Verweis auf die Excel-Bibliothek gesetzt wurde!" & vbLf & _
"Das Pogramm wurde nicht ausgeführt!", vbExclamation
wb.Close savechanges:=False
Exit Sub
DateiOffen:
MsgBox "Die Datei ist bereits geöffnet." & vbLf & _
"Bitte schließen Sie die Datei und führen Sie" & vbLf & _
"das Programm erneut aus!", vbExclamation
wb.Close savechanges:=False
Exit Sub
End Sub
Danke für Eure Unterstützung.