AW: Email m. PDF Anhang über Verteiler
25.01.2021 11:39:23
Andreas
Hallo Stefan,
sieh dir mal meinen Code an, den benutze ich erfolgreich für dein Vorhaben (jedoch in Word, aber das Anpassen sollte überschaubar sein):
Public Sub PDF_Speichern_Mail()
'by Xpert on www.pctipp.ch/forum (04.12.2012)
Dim strDateiname As String
Dim strPfad As String
Dim strPDF As String
Dim intPosition As Integer
Dim intLaenge As Integer
Dim intEndung As Integer
Dim strZellinhalt As String
Dim strErsteZeile As String
Dim Pos As Long
strPfad = ActiveDocument.Path & "\"
strDateiname = ActiveDocument.Name
intLaenge = Len(strDateiname)
intPosition = InStrRev(strDateiname, ".")
intEndung = intLaenge - intPosition
Select Case intEndung
Case 0
strPDF = strPfad & strDateiname & " - zur Abstimmung.pdf"
Case 3
strDateiname = Left(ActiveDocument.Name, Len(ActiveDocument.Name) - 4)
strPDF = strPfad & strDateiname & Left(strDateiname, i) & " - zur Abstimmung" & ".pdf"
Case 4
strDateiname = Left(ActiveDocument.Name, Len(ActiveDocument.Name) - 5)
strPDF = strPfad & strDateiname & Left(strDateiname, i) & " - zur Abstimmung" & ".pdf"
Case Else
MsgBox "Die Dateiendung wurde nicht erkannt!", vbExclamation, "Unbekannte Dateiendung"
End Select
ActiveDocument.ExportAsFixedFormat OutputFileName:=strPDF, ExportFormat:=wdExportFormatPDF, _
OpenAfterExport:=False, OptimizeFor:=wdExportOptimizeForPrint, Range:= _
wdExportAllDocument, From:=1, to:=1, Item:=wdExportDocumentContent, _
IncludeDocProps:=True, KeepIRM:=True, CreateBookmarks:= _
wdExportCreateHeadingBookmarks, DocStructureTags:=True, BitmapMissingFonts:= _
True, UseISO19005_1:=False
'Kunde auslesen
strZellinhalt = ActiveDocument.Tables(1).Cell(2, 1).Range.Text
strZellinhalt = Left(strZellinhalt, Len(strZellinhalt) - 2)
If strZellinhalt "" Then
Pos = InStr(1, strZellinhalt, Chr(13), vbTextCompare)
If Pos > 0 Then
strErsteZeile = Left(strZellinhalt, Pos - 1)
End If
End If
Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)
With objMail
.to = "" 'An-Empfänger
.cc = "" 'Cc-Empfänger
.bcc = "" 'BCc-Empfänger
.Subject = "" 'Betreff
.Body = "" 'Nachricht
.Attachments.Add strPDF 'Anlage
.Display 'Mail anzeigen
End With
Set objMail = Nothing
Set objOutlook = Nothing
End Sub