Registriert seit: 11.04.2014
Version(en): Office 2007
Hallo,
in deinem geposteten Code sehe ich aber nicht, dass Du die Hinweise von beiden Ralfs berücksichtigt hast (Angabe von der Konstanten statt xlUp und die korrekte Referenz auf das Objekt).
Code: Sub Postnachweis_OUTLOOK()
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
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 = "Meine 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)
Set ws = WB.Sheets(1)
oexcel.Visible = True
oexcel.Activate
letztezeile = oexcel.WB.ws.Cells(oexcel.WB.ws.Rows.Count, 1).End(-4162).Row
lfn = letztezeile + 1
With objMail
UserForm1.TextBox1 = Format(lfn, "0000")
UserForm1.TextBox2 = Format(objMail.ReceivedTime, "dd-mm-yy")
UserForm1.TextBox3 = Format(objMail.ReceivedTime, "hh:mm")
UserForm1.TextBox4 = objMail.SenderEmailAddress
UserForm1.TextBox5 = objMail.Subject
'UserForm1.TextBox6 = objMail.ReceivedTime
'UserForm1.TextBox7 = objMail.ReceivedTime
'UserForm1.TextBox8 = objMail.ReceivedTime
'UserForm1.TextBox9 = objMail.ReceivedTime
End With
Next objMail
UserForm1.Show
End Sub
Gruß Stefan
Win 10 / Office 2016
Registriert seit: 05.11.2016
Version(en): 2010
@Steffl
Das setzten einer Konstante statt XxlUp hat keinen Erfolg gebracht.
Ich habe auch auch probiert
Dim letztezeile As Object
und
Set letztezeile = oexcel.WB.ws.Cells(oexcel.WB.ws.Rows.Count, 1).End(-4162).row (wie in deinem Code)
Ein Versuch produziert den Laufzeitfehler '438'
"Objekt unterstützt dieses Methode oder Eigenschaft nicht".
Gruß
tmessers
Registriert seit: 11.04.2014
Version(en): Office 2007
Hallo,
ich habe es bei mir mal getestet
Code: Sub Postnachweis_OUTLOOK()
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
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 = "Meine 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)
Set ws = WB.Sheets(1)
oexcel.Visible = True
ws.Activate
letztezeile = ws.Cells(ws.Rows.Count, 1).End(-4162).Row
lfn = letztezeile + 1
With objMail
UserForm1.TextBox1 = Format(lfn, "0000")
UserForm1.TextBox2 = Format(objMail.ReceivedTime, "dd-mm-yy")
UserForm1.TextBox3 = Format(objMail.ReceivedTime, "hh:mm")
UserForm1.TextBox4 = objMail.SenderEmailAddress
UserForm1.TextBox5 = objMail.Subject
'UserForm1.TextBox6 = objMail.ReceivedTime
'UserForm1.TextBox7 = objMail.ReceivedTime
'UserForm1.TextBox8 = objMail.ReceivedTime
'UserForm1.TextBox9 = objMail.ReceivedTime
End With
Next objMail
UserForm1.Show
End Sub
Gruß Stefan
Win 10 / Office 2016
Folgende(r) 1 Nutzer sagt Danke an Steffl für diesen Beitrag:1 Nutzer sagt Danke an Steffl für diesen Beitrag 28
• tmessers
Registriert seit: 05.11.2016
Version(en): 2010
@Steffl
Ich weiß nicht warum, aber jetzt funktioniert der Code.
Danke
Registriert seit: 05.11.2016
Version(en): 2010
So liebe Gemeinde,
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
Zum Aufbau:
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.
Hier der Code
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.
Gruß
tmessers
Registriert seit: 11.04.2014
Version(en): Office 2007
Hallo,
du verwendest hier
Code: letztezeile = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
immer noch nicht die Konstante :s
Gruß Stefan
Win 10 / Office 2016
Registriert seit: 05.11.2016
Version(en): 2010
Hallo Steffl,
Du hast recht. Es funktioniert aber trotzdem einwandfrei.
Was ist der Vorteil der Konstanten?
Gruß
tmessers
Registriert seit: 11.04.2014
Version(en): Office 2007
Hallo,
(26.03.2018, 19:01)tmessers schrieb: Es funktioniert aber trotzdem einwandfrei.
dann hast du den Verweis auf Excel gesetzt. Und zur deiner Frage mit dem Vorteil: Damit arbeitest du versionsunabhänig. siehe hier. Schaue auch in diesen Artikel von Peter Haserodt.
Gruß Stefan
Win 10 / Office 2016
Registriert seit: 05.11.2016
Version(en): 2010
@Steffl
ja, ich habe den Verweis auf Excel gesetzt. War bis dato die einzige Lösung die ich gefunden habe.
Ich werde mich mit de von Dir empfohlenen Tipps mal auseinander setzen. Danke dafür.
|