Blatt als PDF speichern und mailen

Option Explicit Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) Sub Mail() Const cstrCreator = "D:\PDFCreator\pdfcreator.exe" Dim strPDFPath As String strPDFPath = "D:\Test.pdf" ActiveSheet.PrintOut ActivePrinter:="PDFCreator", PrintToFile:=True, PrToFileName:="D:\test. _ _ ps" Sleep 2000 Shell cstrCreator & " /IF""D:\Test.ps"" /OF""" & strPDFPath & """ /DeleteIF" End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Sabrina,
ungetestet, eil PDFCreator nicht vorhanden!

' **********************************************************************
' Modul: Modul1  Typ: Allgemeines Modul
' **********************************************************************

Option Explicit


Sub PrintToPDF_Late()
'Author       : Ken Puls (www.excelguru.ca)
'Macro Purpose: Print to PDF file using PDFCreator
'   (Download from http://sourceforge.net/projects/pdfcreator/)
'   Designed for late bind, no references req'd
Dim pdfjob As Object
Dim sPDFName As String
Dim sPDFPath As String

'/// Change the output file name here! ///
sPDFName = "Test.pdf"
sPDFPath = "D:" & Application.PathSeparator

'Check if worksheet is empty and exit if so
If IsEmpty(ActiveSheet.UsedRange) Then Exit Sub
Set pdfjob = CreateObject("PDFCreator.clsPDFCreator")
With pdfjob
  If .cStart("/NoProcessingAtStartup") = False Then
    MsgBox "Can't initialize PDFCreator.", vbCritical + _
      vbOKOnly, "PrtPDFCreator"
    Exit Sub
  End If
  .cOption("UseAutosave") = 1
  .cOption("UseAutosaveDirectory") = 1
  .cOption("AutosaveDirectory") = sPDFPath
  .cOption("AutosaveFilename") = sPDFName
  .cOption("AutosaveFormat") = 0    ' 0 = PDF
  .cClearCache
End With

'Print the document to PDF
ActiveSheet.PrintOut copies:=1, ActivePrinter:="PDFCreator"

'Wait until the print job has entered the print queue
Do Until pdfjob.cCountOfPrintjobs = 1
  DoEvents
Loop
pdfjob.cPrinterStop = False

'Wait until the file shows up before closing PDF Creator
Do
  DoEvents
Loop Until Dir(sPDFPath & sPDFName) = sPDFName

pdfjob.cClose

Call sendMail(ActiveSheet.Range("Mail").Text, "Dein Betreff", "Deine Nachricht", sPDFPath & sPDFName)

Set pdfjob = Nothing
End Sub

Sub sendMail(ByVal MailAdress As String, ByVal Subject As String, ByVal Message As String, Optional Attach As String = "")
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

On Error Resume Next
With OutMail
  .To = MailAdress
  .Subject = Subject
  .Body = Message
  If Len(Attach) Then .Attachments.Add (Attach)
  .send   'or .Display
End With
On Error GoTo 0

Set OutMail = Nothing
Set OutApp = Nothing
End Sub


Gruß Sepp

Sub PdfWithPDFCreatorZwei() Dim objPDFCreator As Object, objPrint As Object Dim strActPrinter As String On Error GoTo Errorhandler strActPrinter = Application.ActivePrinter Application.ActivePrinter = "PDFCreator" Set objPDFCreator = CreateObject("PDFCreatorBeta.JobQueue") objPDFCreator.Initialize ActiveSheet.PrintOut objPDFCreator.WaitForJob (10) Set objPrint = objPDFCreator.NextJob With objPrint .SetProfileByGuid ("DefaultGuid") .SetProfileSetting "EmailClient.Enabled", "true" .SetProfileSetting "EmailClient.Subject", "Betreff" .SetProfileSetting "EmailClient.Content", "Deine Nachricht" .SetProfileSetting "EmailClient.Recipients", ActiveSheet.Range("Mail").Text .ConvertTo ("E:\Test.pdf") If .IsFinished = True Then objPDFCreator.ReleaseCom End If End With Errorhandler: Application.ActivePrinter = strActPrinter objPDFCreator.ReleaseCom Set objPDFCreator = Nothing Set objPrint = Nothing End Sub Gruß Sepp

Sub ap() Debug.Print Application.ActivePrinter End Sub Stell mal den PDF-Creator als Drucker ein und führe den Code aus, im Direktfenster steht dann der Name, den musst du dann im Code statt "PDFCreator" einfügen. Gruß Sepp

' ********************************************************************** ' Modul: Modul2 Typ: Allgemeines Modul ' ********************************************************************** Option Explicit Sub PdfWithPDFCreatorZwei() Dim objPDFCreator As Object, objPrint As Object Dim strActPrinter As String, strRec As String On Error GoTo Errorhandler strRec = ActiveSheet.Range("Mail").Text If Not IsValidMailAddress(strRec) Then strRec = ActiveSheet.Range("Telefon").Text If Not IsValidMailAddress(strRec) Then strRec = ActiveSheet.Range("Mobil").Text If Not IsValidMailAddress(strRec) Then strRec = InputBox("Bitte Empfängeradresse angeben:", "Mail") If strRec = "" Then Exit Sub End If strActPrinter = Application.ActivePrinter Application.ActivePrinter = "PDFCreator" Set objPDFCreator = CreateObject("PDFCreatorBeta.JobQueue") objPDFCreator.Initialize ActiveSheet.PrintOut objPDFCreator.WaitForJob (10) Set objPrint = objPDFCreator.NextJob With objPrint .SetProfileByGuid ("DefaultGuid") .SetProfileSetting "EmailClient.Enabled", "true" .SetProfileSetting "EmailClient.Subject", "Betreff" .SetProfileSetting "EmailClient.Content", "Deine Nachricht" .SetProfileSetting "EmailClient.Recipients", strRec .ConvertTo ("E:\Test.pdf") If .IsFinished = True Then objPDFCreator.ReleaseCom End If End With Errorhandler: Application.ActivePrinter = strActPrinter Set objPDFCreator = Nothing Set objPrint = Nothing End Sub Private Function IsValidMailAddress(ByVal strAddress As String) As Boolean Dim oRegExp As Object Set oRegExp = CreateObject("vbscript.regexp") With oRegExp .Pattern = "[a-z0-9!#$%&'*+/=?^_`{|}~-]+(?:\.[a-z0-9!#$%&'*+/=?^_`{|" & _ "}~-]+)*@(?:[a-z0-9](?:[a-z0-9-]*[a-z0-9])?\.)+[a-z0-9](?:" & _ "[a-z0-9-]*[a-z0-9])?" .IgnoreCase = True IsValidMailAddress = .test(strAddress) End With Set oRegExp = Nothing End Function Gruß Sepp

Beliebteste Forumthreads (12 Monate)

Blatt als PDF speichern und mailen

16
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

335 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Blatt als PDF speichern und mailen

16 Beiträge zum Forumthread Beiträge zu diesem Forumthread

335 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

16
Beiträge zum Forumthread

Beiträge zu diesem Forumthread