PDF-Seriendruck über VBA steuern?

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo
Bei deinem Level solltest du das relativ einfach anpassen können :-)
Der Code ist eigentlich dafür gedacht, die aktuelle Tabelle als PDF zu drucken.
Mit einer Schleife kannst du den Code dann für deine Anforderungen anpassen indem du immer Print_to_PDF("DeineTabelle") aufrufst und als Parameter eben den Namen deiner Tabelle

'Adobe Print Job
'by Ramses

Sub Start_Print()
    '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" sowie "Acrobat" (Apllication)
    '*********************************
    '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
    Open_PDF DistOutputPDF
End Sub

Sub Open_PDF(FileToOpen As String)
    'by Ramses
    '****************
    'Verweis auf Acrobat Application setzen !!!
    '****************
    Dim myAdobeAc As Acrobat.CAcroApp
    Dim myAdobeDoc As Acrobat.CAcroPDDoc
    Dim myAdobeView As Acrobat.CAcroAVDoc
    'Adobe Application zuweisen
    Set myAdobeAc = CreateObject("AcroExch.App")
    'Adobe Dokument Handler zuweisen
    Set myAdobeDoc = CreateObject("AcroExch.PDDoc")
    If myAdobeDoc.Open(FileToOpen) Then
        myAdobeAc.Show
        'Adobe View Handler zuweisen
        'um mit dem Dokument allenfalls arbeiten zu können
        'via VBA
        Set myAdobeView = myAdobeDoc.OpenAVDoc("")
    Else
        MsgBox "Unable to open the PDF-file", vbInformation
    End If
    Set myAdobeView = Nothing
    Set myAdobeDoc = Nothing
    Set myAdobeAc = Nothing
End Sub

Function Get_Adobe_Printer() As String
    'Adobe Drucker bestimmen
    'Code zum Druckerauslesen ist Bestandteil dieses Codes
    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
Dazu muss in die Mappe ein Klassenmodul erstellt werden mit dem Namen classAcroDist
In das Klassenmodul muss dieser Code

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
    Kill strInputPostScript
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

Viel Spass :-)
Gruss Rainer

Hallo Luschi
Danke für den Hinweis,... das ist beim kopieren tatsächlich vergessen gegangen :-(

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

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)
        GetProfileString "PrinterPorts", strPrinterNames(intIndex), "", strBuffer, Len(strBuffer)
        prcGetDriverAndPort strBuffer, strPrinterPorts(intIndex)
    Next
End Sub

Viel Spass beim ausprobieren :-)
Gruss Rainer

Beliebteste Forumthreads (12 Monate)

PDF-Seriendruck über VBA steuern?

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

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread