AW: Code erweitern um PDF Senden
07.09.2022 13:44:20
Bernhard
Hallo Nepumuk,
habe es jetzt endlich hinbekommen, der Fehler lag hier:
.HTMLBody = Range("O9").Text & "
" & "
" & Range("O11").Text & "
" & Range("O12").Text & "
" & olOldHtmlBody
hatte olOldHtmlBody nicht hinten angefügt.
hier der Code, kannst du noch mal drüber scheuen ob es so ok ist oder ob es was zu verbessern gibt?
Danke :-)
Option Explicit
Sub Serienbrief()
Const Bewertung As String = "G:\SteloTec\Managementsystem\Einkauf\Lieferantenbewertung\LFT_Bewertung_2022_neu.xlsx"
Const FOLDER_PATH As String = "G:\SteloTec\Managementsystem\Einkauf\Lieferantenbewertung\Lieferantenbewertung_2022\"
Dim OutlookApp As Object, OutlookMailItem As Object
Dim WB As Workbook
Dim i As Long
Dim strPath As String
Dim olOldHtmlBody As String, UserPfad As String, UserDatei As String
Const olBodyFormat As Integer = 2 ''Html-Format
ChDrive Left("G:\SteloTec\Managementsystem\Einkauf\Lieferantenbewertung\LFT_Bewertung_2022_neu.xlsx", 1)
ChDir "G:\SteloTec\Managementsystem\Einkauf\Lieferantenbewertung\Lieferantenbewertung_2022\"
Set WB = Workbooks.Open(Bewertung, 0, 0)
ThisWorkbook.Activate
Set OutlookApp = CreateObject("Outlook.Application")
With WB.Sheets("Bewertung")
For i = 9 To .Cells(.Rows.Count, 1).End(xlUp).Row
Cells(14, "I") = .Cells(i, 1)
strPath = FOLDER_PATH & Range("D25").Value & "_" & Range("A14").Value & "_" & Format$(Date, "YYYYMMDD") & ".pdf"
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=strPath, Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
Set OutlookMailItem = OutlookApp.CreateItem(0)
Do While Dir(UserDatei, vbNormal) = ""
DoEvents
Loop
''late binding - kein VCba-Verweis auf M$ Outlook xx.0 Object Library erforderlich
With OutlookMailItem
.BodyFormat = olBodyFormat
.GetInspector.Display
olOldHtmlBody = .HTMLBody
.To = Range("O6").Text
.Subject = Range("O8").Text
.HTMLBody = Range("O9").Text & "
" & "
" & Range("O11").Text & "
" & Range("O12").Text & "
" & olOldHtmlBody
.Attachments.Add strPath
.Display
End With
Next i
End With
WB.Close 0
Set WB = Nothing
Set OutlookMailItem = Nothing
Set OutlookApp = Nothing
End Sub
Gruß
Bernhard