AW: Einzelnes Tabellnblatt in PDF Datei speichern
27.02.2009 16:07:44
Ramses
Hallo
So einfach wie Dieter das beschreibt geht es mit dem PDF Drucker eben leider nicht :-)
... und mit Acrobat erst recht nicht :-)
Ich habe dies vor längerer Zeit mal für ein Projekt gemacht. Es funktoiniert unter Adobe 6 und 7.
Ob es mit der 8er Version funktioniert weiss ich leider nicht, aber du kannst das ja mal testen und mir dann Bescheid geben.
Lass dich nicht von der "Masse" Code täuschen, es geht vielleicht auch kürzer und vielleicht auch noch eleganter. Aber ich hatte keine Lust das Teil zu optimieren :-)
Erstelle in deiner eine Mappe ein Modul und benenne dies z.B. mit "Adobe_Print" und füge dort diesen Code komplett ein
Option Explicit
'Code zur Verwendung mit Adobe Acrobat 6./7.0
'Im VB-Editor die Verweise setzen auf die Objectlibraries:
'Microsoft Office 10.0 bzw. 11.0 Object Library
'Acrobat Distiller
'Acrobat Application
'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
'Adobe Print Job
'(C) by Ramses
'*********************************
'Zusätzlich wird das Klassenmodul classAcroDist benötigt !!!
'*********************************
'Mit dieser Sequenz wird der Ausdruck gestartet
Sub Start_Print()
'Druckt die aktuelle 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)
'(C) by Ramses
'*********************************
'Verweise setzen auf
'Microsoft Office 10.0 / 11.0 Object Library und
'"Acrobat Distiller" sowie "Acrobat" (Application)
'*********************************
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)
'(C) 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
'(C) by Ramses
'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)
Debug.Print strPrinterNames(intIndex) & " auf " & strPrinterPorts(intIndex)
Exit For
End If
Next
End Function
Private Sub prcGetPrinterNames(ByVal strBuffer As String)
'by Nepumuk
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()
'by Nepumuk
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
Private Sub prcGetDriverAndPort(ByVal Buffer As String, PrinterPort As String)
'by Nepumuk
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)
End If
End If
End Sub
Anschliessend erstellst du ein Klassenmodul und benennst dieses als "classAcroDist".
Dort fügst du diesen Code ein
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
ACHTUNG:
Die Verweise müssen unbedingt im VB-Editor gesetzt sein, sonst hagelt es Fehlermeldungen
Viel Spass und gib Bescheid ob es funktioniert
Gruss Rainer
