Pdf Drucken automatisch

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo
wenn es elegant sein soll, dann ist es eben nicht ganz trivial :-)
Das muss in ein Modul
Option Explicit
'Liest alle unter dem aktuell angemeldeten Benutzer
'installierten Drucker aus
'by Nepumuk
Private Declare Function GetProfileString Lib "kernel32" Alias "GetProfileStringA" ( _
    ByVal lpAppName As String, _
    ByVal lpKeyName As String, _
    ByVal lpDefault As String, _
    ByVal lpReturnedString As String, _
    ByVal nSize As Long) As Long

Private Const MAX_PRINTERS = 16
Private strPrinterNames(MAX_PRINTERS) As String
Private strPrinterDrivers(MAX_PRINTERS) As String
Private strPrinterPorts(MAX_PRINTERS) As String
Private intPrinterCount As Integer

Sub Start_Print()
    'by Ramses
    'Druckt die übergebene Tabelle als PDF-Datei
    'in das aktuelle Verzeichnis wo die Mappe gespeichert ist
    Call Print_to_PDF(ActiveSheet)
End Sub

Public Sub Print_to_PDF(tarWks As Worksheet)
    'by Ramses
    '*********************************
    'Verweise setzen auf
    'Microsoft Office 10.0 / 11.0 Object Library und
    'Acrobat Distiller
    '*********************************
    'Zusätzlich wird das Klassenmodul classAcroDist benötigt
    Dim myAdobeDist As classAcroDist 'see class module
    Dim myWB As Workbook
    Dim strFilename As String
    Dim strFileToPrintPfad As String
    Dim DistInputPS As String
    Dim DistOutputPDF As String
    Dim DistJobOptions As String
    Dim oldActivePrinter As String
    Set myAdobeDist = New classAcroDist
    'Distiller ausgeblendet startetn
    myAdobeDist.myAdobeDist.bShowWindow = False
    'Alle aktuellen Printjobs des Distillers stoppen
    myAdobeDist.myAdobeDist.bSpoolJobs = False
    'Alten Drucker aufnehmen
    oldActivePrinter = Application.ActivePrinter
    'Workbook zuweisen
    Set myWB = Workbooks(tarWks.Parent.name)
    'Pfad der Mappe extrahieren
    strFileToPrintPfad = myWB.Path
    'Dann wechsle vorher in den Pfad der Datei
    ChDrive (Left(strFileToPrintPfad, 2))
    ChDir myWB.Path
    'Zur druckender: Mappenname_Tabelle1
    strFilename = strFileToPrintPfad & "\" & Left(myWB.name, Len(myWB.name) - 4) & "_" & tarWks.name
    'EXCEL kann nur PS-Files direkt drucken
    'daher muss sowohl PS-File wie auch PDF-File definiert werden
    DistInputPS = strFilename & ".ps"
    DistOutputPDF = strFilename & ".pdf"
    'Der Druckername wird automatisch ermittelt
    'in der Funktion "Get_Adobe_Printer"
    myWB.PrintOut ActivePrinter:=Get_Adobe_Printer, prtoFilename:=DistInputPS, PrintToFile:=True
    'Dem Distiller das PS-File zum konvertieren übergeben
    Call myAdobeDist.myAdobeDist.FileToPDF(DistInputPS, DistOutputPDF, DistJobOptions)
    'Schauen wie lange er braucht
    'und STatus OK meldet
    Do While Not myAdobeDist.blnFinished
        DoEvents
    Loop
    If myAdobeDist.blnFinished Then
        MsgBox "PDF Printjob erfolgreich beendet"
    Else
        MsgBox "Fehler beim Druck in PDF Datei aufgetreten"
    End If
    'Alten Drucker wieder herstellen
    Application.ActivePrinter = oldActivePrinter
    'Variablen leeren
    Set myAdobeDist = Nothing
End Sub

Function Get_Adobe_Printer() As String
    'Adobe Drucker bestimmen
    Dim strBuffer As String
    Dim intIndex As Integer
    strBuffer = Space$(8192)
    GetProfileString "PrinterPorts", vbNullString, "", strBuffer, Len(strBuffer)
    prcGetPrinterNames strBuffer
    prcGetPrinterPorts
    For intIndex = 0 To intPrinterCount
        If InStr(1, strPrinterNames(intIndex), "Adobe") > 0 Then
            'Genaue Druckerbezeicnung übergeben
            Get_Adobe_Printer = strPrinterNames(intIndex) & " auf " & strPrinterPorts(intIndex)
            Exit For
        End If
    Next
End Function

Private Sub prcGetPrinterNames(ByVal strBuffer As String)
    Dim intIndex As Integer
    Dim strName As String
    intPrinterCount = 0
    Do
        intIndex = InStr(strBuffer, Chr(0))
        If intIndex > 0 Then
            strName = Left$(strBuffer, intIndex - 1)
            If Len(Trim$(strName)) > 0 Then
                strPrinterNames(intPrinterCount) = Trim$(strName)
                intPrinterCount = intPrinterCount + 1
            End If
            strBuffer = Mid$(strBuffer, intIndex + 1)
        Else
            If Len(Trim$(strBuffer)) > 0 Then
                strPrinterNames(intPrinterCount) = Trim$(strBuffer)
                intPrinterCount = intPrinterCount + 1
            End If
            strBuffer = ""
        End If
    Loop While (intIndex > 0) And (intPrinterCount < MAX_PRINTERS)
End Sub

Private Sub prcGetPrinterPorts()
    Dim strBuffer As String
    Dim intIndex As Integer
    For intIndex = 0 To intPrinterCount - 1
        strBuffer = Space$(1024)
        Debug.Print GetProfileString("PrinterPorts", strPrinterNames(intIndex), "", strBuffer, Len(strBuffer))
        GetProfileString "PrinterPorts", strPrinterNames(intIndex), "", strBuffer, Len(strBuffer)
        prcGetDriverAndPort strBuffer, strPrinterPorts(intIndex)
    Next
End Sub

Private Sub prcGetDriverAndPort(ByVal Buffer As String, PrinterPort As String)
    Dim intDriver As Integer
    Dim intPort As Integer
    PrinterPort = ""
    intDriver = InStr(Buffer, ",")
    If intDriver > 0 Then
        intPort = InStr(intDriver + 1, Buffer, ",")
        If intPort > 0 Then
            PrinterPort = Mid$(Buffer, intDriver + 1, intPort - intDriver - 1)
            Debug.Print PrinterPort
        End If
    End If
End Sub

Das gehört in ein Klassenmodul deiner Mappe
Einfügen - Klassenmodul
Der Name muss lauten classAcroDist
Option Explicit

Public WithEvents myAdobeDist As PdfDistiller
Public blnFinished As Boolean

Private Sub Class_Initialize()
    Set myAdobeDist = New PdfDistiller
End Sub

Private Sub myAdobedist_OnJobDone(ByVal strInputPostScript As String, ByVal strOutputPDF As String)
    blnFinished = True
    'Altes PS-File löschen
    Kill strInputPostScript
    'Distiller Log Datei löschen
    Kill Left(strInputPostScript, Len(strInputPostScript) - 3) & ".log"
End Sub

Private Sub myAdobedist_OnJobFail(ByVal strInputPostScript As String, ByVal strOutputPDF As String)
    blnFinished = True
End Sub

Private Sub myAdobedist_OnJobStart(ByVal strInputPostScript As String, ByVal strOutputPDF As String)
    blnFinished = False
End Sub

Starten kannst du das ganze dann mit
Start_Print()
oder eben
Call Print_to_PDF(Worksheets("Tabelle1"))
dann wird die Tabelle1 als PDF gedruckt
Gruss Rainer

Beliebteste Forumthreads (12 Monate)

2 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread