Outlook/Excel

[Steffl]

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

[tmessers]

@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

[Steffl]

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

[tmessers]

@Steffl

Ich weiß nicht warum, aber jetzt funktioniert der Code.

Danke

[tmessers]

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

[Steffl]

Hallo,

du verwendest hier

Code:

letztezeile = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row

immer noch nicht die Konstante :s

[tmessers]

Hallo Steffl,

Du hast recht. Es funktioniert aber trotzdem einwandfrei.
Was ist der Vorteil der Konstanten?

Gruß

tmessers

[Steffl]

Hallo,

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.

[tmessers]

@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.