Serienbrief erzeugt und gespeichert keine Mail möglich
05.02.2024 14:33:04
Holger
Ich habe eine größere Excel Kundendatei erzeugt Es sind 50 Kunden die Arbeitsnachweise bekommen sollen. Ich erzeuge die Berichte per Serienbrief in einem Ordner der nach Datum erzeugt und als Worddokument gespeichert. Im gleichen Schritt wird das Word als PDF gewandelt und je nach Auswahl einer Zelle in den Orner PDF gespeichert oder in den Ordner Mail. Ich möchte das automatisiert die PDF Dokumente die im Orner Mail gespeichert sind per Anhang gesendet werden. Da kommt es dann aber zum Debuggen. Laufzeitfehler 1004 Die Methode Range für das Objekt _Worksheet ist fehlgeschlagen. Ich hab das im Code Markiert mit '----hier ist das Problem ------
Vieleicht hat jemand einen Tipp zur Problemlösung. Es ist auch nicht den kompletten Code, wäre zu verwirrend.
Sub ExportToWord2()
Dim wordapp As New Word.Application
Dim doc As Word.Document
Dim Zeile As Long
Dim FSO As New FileSystemObject
Dim strPfad As String
Dim heute As String
Dim Ordner As String
Dim oApp As New Outlook.Application
Dim oMail As Outlook.MailItem
Dim DateiName As String
'pfad setzen und Ordner erstellen
strPfad = "D:\Mario\Berichte\datum"
FSO.CreateFolder strPfad & "\" & Format(Date, "DD-MM-YYYY")
Ordner = FSO.GetFolder(strPfad)
'Word sichtbar machen
wordapp.Visible = True
For Zeile = 2 To shArbeitsnachweise_drucken.Cells(Rows.Count, 1).End(xlUp).Row
'Word-Datei öffnen
Set doc = wordapp.Documents.Open("D:\Mario\Einsatzbericht1.docx")
'Word-Datei mit Exceldaten befüllen
doc.Bookmarks("Name").Range.Text = shArbeitsnachweise_drucken.Cells(Zeile, 2).Value
doc.Bookmarks("Straße").Range.Text = shArbeitsnachweise_drucken.Cells(Zeile, 3).Value
doc.Bookmarks("Ort").Range.Text = shArbeitsnachweise_drucken.Cells(Zeile, 4).Value
doc.Bookmarks("Mail").Range.Text = shArbeitsnachweise_drucken.Cells(Zeile, 93).Value
doc.Bookmarks("Datum").Range.Text = shArbeitsnachweise_drucken.Cells(Zeile, 6).Value
doc.Bookmarks("Kg").Range.Text = shArbeitsnachweise_drucken.Cells(Zeile, 7).Value
'Es geht noch weiter bis zur Zelle 92 .............
' neuen Pfad auslesen
heute = Format(Date, "DD-MM-YYYY")
strPfad = "D:\Mario\Berichte\Datum\" & heute & "\"
'Word-Datei abspeichern
doc.SaveAs2 strPfad & shArbeitsnachweise_drucken.Cells(Zeile, 1) & " " & shArbeitsnachweise_drucken.Cells(Zeile, 2).Value & ".docx"
'Word als PDF speichern
If shArbeitsnachweise_drucken.Cells(Zeile, 86).Value = "Ja" Then
doc.ExportAsFixedFormat "D:\Mario\Berichte\MAIL\" & shArbeitsnachweise_drucken.Cells(Zeile, 1) & " " & shArbeitsnachweise_drucken.Cells(Zeile, 2).Value & " " & shArbeitsnachweise_drucken.Cells(Zeile, 86).Value & ".pdf", wdExportFormatPDF
DateiName = "D:\Mario\Berichte\MAIL\" & shArbeitsnachweise_drucken.Cells(Zeile, 1) & " " & shArbeitsnachweise_drucken.Cells(Zeile, 2).Value & " " & shArbeitsnachweise_drucken.Cells(Zeile, 86).Value & ".pdf"
'PDF per Mail senden
' ---------------- hier ist das Problem ---------------
'------------------------------------------------------
Set oMail = oApp.CreateItem(olMailItem)
With oMail
.BodyFormat = olFormatHTML
.Display
.To = shAbrechnung.Range("Zeile, 2").Value
'.Subject = "Arbeitsnachweis vom Zeitraum" & " " & shAbrechnung.Range("Zeile, 87").Value & " bis zum " & shAbrechnung.Range("Zeile, 88").Value
.Subject = "Arbeitsnachweis vom Zeitraum"
.HTMLBody = "Sehr geehrte(r)" & " " & shAbrechnung.Range("Zeile, 2").Value
.Attachments.Add DateiName
.Send
End With
Else
doc.ExportAsFixedFormat "D:\Mario\Berichte\PDF\" & shArbeitsnachweise_drucken.Cells(Zeile, 1) & " " & shArbeitsnachweise_drucken.Cells(Zeile, 2).Value & " " & shArbeitsnachweise_drucken.Cells(Zeile, 86).Value & ".pdf", wdExportFormatPDF
End If
'Word-Datei schließen
doc.Close savechanges:=False
Next Zeile
'Word-Applikation schließen
wordapp.Quit
End Sub