VBA - Tabelle als PDF an mehrere in BCC

Private Sub SendSheetOutlook(sSubject As String, sTo As String, sBCC As String, sText As String) _ Dim olApp As Object Dim AWS As String Dim olOldBody As String 'define temporary Path and Filename AWS = MyPath & "\" & Format(Date, "YYYYMMDD") & "_" & Format(Time, "hhmmss") & "_" & _ WorksheetFunction.Substitute(ActiveWorkbook.Name, ".xlsm", "") 'export File as PDF ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=AWS, Quality:=xlQualityStandard, _ IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False AWS = AWS & ".pdf" 'Make Email Set olApp = CreateObject("Outlook.Application") With olApp.CreateItem(0) .GetInspector.Display olOldBody = .htmlBody .To = sTo .bcc = sBCC .Subject = sSubject .htmlBody = sText & olOldBody .Attachments.Add AWS End With 'remove TEMP file 'wenn du das PDF behalten möchtest, diese Zeile auskommentieren! 'sonst wird das temporäre PDF wieder gelöscht 'Kill AWS End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Markus,
hier noch ein Update. Der 1. Arbeitstag ist ja nicht immer Montags, da hatte ich ein Brett vor'm Kopf.

Function Get_BCC() As String

'Ermittelt die BCC-Empfänger aus einem Tabellenblatt

 Dim sCheck As String, iZeile As Long, i As Integer, Datum As Date

 Dim sFT As String

'Feiertage festlegen

 Const sFTs = "01.01,06.01,01.05.,03.10.,01.11.,"

 sCheck = "t"                                       'Jeden Tag

 If Weekday(Date, 1) = 4 Then sCheck = sCheck & "w" 'Mittwoch

 For i = 1 To 7

  Datum = CDate(Format$(i & Mid$(Date, 3), "dd.mm.yyyy"))

  sFT = Left$(Datum, 6) & ","

  If Weekday(Datum) &LT;&GT; 1 And Weekday(Datum) &LT;&GT; 7 And InStr(sFTs, sFT) = 0 Then

    If (Date) = Datum Then sCheck = sCheck & "m"    'Erster Arbeitstag

    Exit For

  End If

 Next i

 With ThisWorkbook.Sheets("BCC-Liste")              'Tabellenblatt anpassen

    For iZeile = 2 To .UsedRange.Rows.Count         'Alle Zeilen durchgehen

     If .Cells(iZeile, "A").Value &LT;&GT; "" Then        'Wert vorhanden?

      If InStr(sCheck, .Cells(iZeile, "B").Value) &GT; 0 Then

        Get_BCC = Get_BCC & .Cells(iZeile, "A").Value & ";"

      End If

     End If

    Next iZeile

 End With

 If Get_BCC &LT;&GT; "" Then Get_BCC = Left$(Get_BCC, Len(Get_BCC) - 1)

End Function

viele Grüße
Karl-Heinz

Hi Karl-Heinz,
dein Tip war genau richtig.
Ich habe das folgendermaßen gelöst (Kommentar Test):

Sub SendSheetAsPDF()
Dim emailAlias As String 'Test
Dim MailTo As String
Dim MailBCC As String
Dim MailSubject As String
Dim MailText As String
'Test
emailAlias = "mailadresse"
'Email Adresse an
MailTo = "mailadresse"
'BCC-Adressen: Funktion!
MailBCC = Get_BCC()
'Betreff:
MailSubject = "Test vom " & Format(Date, "DD. MMM YYYY")
'Standardtext, im Maildisplay noch änderbar
MailText = "Sehr geehrte Damen und Herren, 
 dies ist ein Test."
Call SendSheetOutlook(MailSubject, emailAlias, MailTo, MailBCC, MailText) 'Test
End Sub

'***************************************************************************
'Makro to send Excel-Sheet directly with outlook
'April 2013 by Klaus M.vdT.
'MODIFIED June 2013: Send pdf, not xlsx!
'original Code by mumpel / www.herber.de / 11.04.2013 11:23:25
'https:\/\/www.herber.de/forum/messages/1308295.html
Private Sub SendSheetOutlook(sSubject As String, emailAlias As String, sTo As String, sBCC As  _
String, sText As String) 'Test
Dim olApp         As Object
Dim AWS           As String
Dim olOldBody     As String
'define temporary Path and Filename
AWS = MyPath & "\" & ActiveSheet.Name & "_" & Format(Date, "DDMMYYYY")
'export File as PDF
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=AWS, Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
AWS = AWS & ".pdf"
'Make Email
Set olApp = CreateObject("Outlook.Application")
With olApp.CreateItem(0)
.SentOnBehalfOfName = emailAlias 'Test
.GetInspector.Display
olOldBody = .htmlBody
.To = sTo
.bcc = sBCC
.Subject = sSubject
.htmlBody = sText & olOldBody
.Attachments.Add AWS
End With
'remove TEMP file
'wenn du das PDF behalten möchtest, diese Zeile auskommentieren!
'sonst wird das temporäre PDF wieder gelöscht
'Kill AWS
End Sub
Function Get_BCC() As String
'Ermittelt die BCC-Empfänger aus einem Tabellenblatt
Dim sCheck As String, iZeile As Long, i As Integer, Datum As Date
Dim sFT As String
'Feiertage festlegen
Const sFTs = "01.01,06.01,01.05.,03.10.,01.11.,"
sCheck = "t"                                       'Jeden Tag
If Weekday(Date, 1) = 4 Then sCheck = sCheck & "w" 'Mittwoch
For i = 1 To 7
Datum = CDate(Format$(i & Mid$(Date, 3), "dd.mm.yyyy"))
sFT = Left$(Datum, 6) & ","
If Weekday(Datum)  1 And Weekday(Datum)  7 And InStr(sFTs, sFT) = 0 Then
If (Date) = Datum Then sCheck = sCheck & "m"    'Erster Arbeitstag
Exit For
End If
Next i
With ThisWorkbook.Sheets("Liste")              'Tabellenblatt anpassen
For iZeile = 2 To .UsedRange.Rows.Count         'Alle Zeilen durchgehen
If .Cells(iZeile, "A").Value  "" Then        'Wert vorhanden?
If InStr(sCheck, .Cells(iZeile, "B").Value) > 0 Then
Get_BCC = Get_BCC & .Cells(iZeile, "A").Value & ";"
End If
End If
Next iZeile
End With
If Get_BCC  "" Then Get_BCC = Left$(Get_BCC, Len(Get_BCC) - 1)
End Function

Damit ist der Code auch für andere Nutzer vollständig.
Nochmals vielen herzlichen Dank Karl-Heinz. Du hast mir den Tag gerettet!
Gruß
Markus

Beliebteste Forumthreads (12 Monate)

VBA - Tabelle als PDF an mehrere in BCC

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

320 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

VBA - Tabelle als PDF an mehrere in BCC

7 Beiträge zum Forumthread Beiträge zu diesem Forumthread

320 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread