habe schon wieder ein Problem.
Hatte unter Excel 2003 mit dem PDF Creater bestimmte Sheets mit einem Makro per Knopfdruck gespeichert und versendet.
Irgendwann ging es nicht mehr.
Jetzt wechsel ich auf Excel 2013 und möchte das gleiche Marko, aber nur mit dem Microsoft Drucker machen. Dieser heisst bei mir Microsoft Print to PDF.
Ich bekomme es aber einfach nicht hin. Was muss ich ändern?
LG
Sabbel
Sub PDF_mailen(Auswahl)
Application.ScreenUpdating = False
Dim objPDFCreator As Object, objPrint As Object
Dim strActPrinter As String, strRec As String, spe8 As String, GeraeteArt As String
On Error GoTo Errorhandler
GeraeteArt = ActiveSheet.Range("GeraeteArt").Value
spe8 = ActiveSheet.Range("spe8").Value
strRec = ActiveSheet.Range("spe6").Text
If Range("spe8") = "" Then
MsgBox "Es fehlt die Autragsnummer!", 0, "Antwortfenster"
Exit Sub
End If
If Not IsValidMailAddress(strRec) Then strRec = ActiveSheet.Range("spe7").Text
If Not IsValidMailAddress(strRec) Then strRec = ActiveSheet.Range("spe116").Text
If Not IsValidMailAddress(strRec) Then
strRec = InputBox("Bitte Empfängeradresse angeben:", "Mail")
If strRec = "" Then Exit Sub
End If
strActPrinter = Application.ActivePrinter
Debug.Print Application.ActivePrinter
Application.ActivePrinter = "PDFCreator auf Ne02:"
Set objPDFCreator = CreateObject("PDFCreator.JobQueue")
objPDFCreator.Initialize
' Seite zum Mailen auswählen
' Kostenvoranschlag
If Auswahl = "Kostenvoranschlag" Then
If GeraeteArt = "Smartphone" Or GeraeteArt = "Tablet" Then
Windows("Ausdruck.xls").Activate
Sheets("SmartphoneKVA").Select
ActiveSheet.PrintOut From:=2, TO:=2
Else
Windows("Ausdruck.xls").Activate
Sheets("Kostenvoranschlag").Select
ActiveSheet.PrintOut From:=2, TO:=2
End If
Windows("Ausdruck.xls").Visible = False
End If
' Auftrag
If Auswahl = "Auftrag" Then
If GeraeteArt = "Wert1" Or GeraeteArt = "Wert2" Then
Windows("Ausdruck.xls").Activate
Sheets("Seite1").Select
ActiveSheet.PrintOut From:=2, TO:=2
Else
Windows("Ausdruck.xls").Activate
Sheets("Seite2").Select
ActiveSheet.PrintOut From:=2, TO:=2
Windows("Ausdruck.xls").Visible = False
End If
Windows("Ausdruck.xls").Visible = False
End If
' Auswahl Ende
objPDFCreator.WaitForJob (10)
Set objPrint = objPDFCreator.NextJob
With objPrint
.SetProfileByGuid ("DefaultGuid")
.SetProfileSetting "EmailClient.Enabled", "true"
.SetProfileSetting "EmailClient.Subject", Auswahl & " " & spe8
.SetProfileSetting "EmailClient.Content", "Deine Nachricht"
.SetProfileSetting "EmailClient.Recipients", strRec
.ConvertTo ("D:\Auftrag\PDF\" & Auswahl & " " & spe8 & ".pdf")
If .IsFinished = True Then
objPDFCreator.ReleaseCom
End If
End With
Errorhandler:
'Application.ActivePrinter = strActPrinter
Set objPDFCreator = Nothing
Set objPrint = Nothing
End Sub