AW: Mehere Sheets auswählen dann als PDF senden
06.03.2019 21:29:44
Nepumuk
Hallo Holly,
teste jetzt mal:
Private Sub CommandButton1_Click()
Dim app As Object
Dim file As String
Dim isNew As Boolean
Dim aobjWorksheets() As Worksheet, objActiveSheet As Worksheet
Dim lngIndex As Long, ialngWorksheetIndex As Long
Dim blnSelectWorksheet As Boolean
file = "Dienstplan Aushang.pdf"
With ListBox1
For lngIndex = 0 To .ListCount - 1
If .Selected(lngIndex) Then
Redim Preserve aobjWorksheets(ialngWorksheetIndex)
Set aobjWorksheets(ialngWorksheetIndex) = ThisWorkbook.Worksheets(.List(lngIndex))
ialngWorksheetIndex = ialngWorksheetIndex + 1
blnSelectWorksheet = True
End If
Next
End With
If Not blnSelectWorksheet Then
Call MsgBox("Bitte wählen Sie eine Tabelle aus.", vbExclamation, "Hinweis")
Else
Application.ScreenUpdating = False
Set objActiveSheet = ActiveSheet
For ialngWorksheetIndex = 0 To UBound(aobjWorksheets)
Call aobjWorksheets(ialngWorksheetIndex).Select(Replace:=ialngWorksheetIndex = 0)
Next
Call ActiveSheet.ExportAsFixedFormat(Type:=xlTypePDF, _
Filename:=Environ$("TEMP") & "\" & file, _
Quality:=xlQualityStandard, IncludeDocProperties:=False, _
IgnorePrintAreas:=False, OpenAfterPublish:=False)
Set app = GetObject(, "Outlook.Application")
If app Is Nothing Then
Set app = CreateObject("Outlook.Application")
isNew = True
End If
With app.CreateItem(0)
.To = "Holger-Schremb@web.de" & ";" 'Die E-Mail-Adresse wurde aus Datenschutzgründen entfernt. ***
.CC = ""
.BCC = ""
.Subject = "Anlage: " & file
.Body = "Sehr geehrte Damen und Herren." & vbCr _
& vbCr _
& "Anbei das Excel-Dokument als PDF." & vbCr _
& vbCr _
& "Mit freundlichen Grüßen."
.Attachments.Add Environ$("TEMP") & "\" & file
.ReadReceiptRequested = True 'Lesebestätigung ein
.Display 'Email anzeigen
End With
If isNew Then app.Quit
Call Kill(PathName:=Environ$("TEMP") & "\" & file)
objActiveSheet.Select
Set app = Nothing
Set objActiveSheet = Nothing
End If
End Sub
Gruß
Nepumuk