Excel Arbeitsblatt zu PDF konvertieren
03.08.2007 21:17:35
Cataal
Hoffentlich könnt ihr mir weiter helfen.
Ich habe vor ein paar Monate einen Code auf diesem Forum gefunden (Nepumuk und
Ramses) die es mir ermöglicht ein Arbeitsblatt zu PDF zu konvertieren. Musste zwar ein paar Anpassungen machen aber es lauft einfach Super
Doch eins verstehe ich nicht! Wenn diese Mappe von mir oder andere Mitarbeiter auf einen anderen PC geöffnet wird dann läuft der Code ins nichts.
Alle PCs haben Adobe Writer installiert.
Ablauf (Kurzversion)
Meinem Code öffnet diverse Mappen eins nacheinander. Von jeder Mappe wird dass Arbeitsblatt Report zu PDF konvertiert und gespeichert.
Code. ..Call Start_Print starts Print_to_PDF
Dann wird
Private Sub Class_Initialize() gestartet
Set myAdobeDist = New PdfDistiller
End Sub
Doch bei Set myAdobeDist = New PdfDistiller lauft dann nichts mehr. Irgendetwas übersehe ich bestimmt aber nach tagelange suche weiß ich einfach nicht mehr weiter. Hat es vielleicht mit Verweise oder Add-ins zu tun? Sieht zwar alles normal aus
Hoffentlich habt ihr eine Ahnung. Wäre damit einfach sehr geholfen!
Grüsse, Robert
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
Public Sub Start_Print()
'Original content 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)
'Original content 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 MyPath As String
Dim strFilename As String
Dim strFileToPrintPfad As String
Dim DistInputPS As String
Dim DistOutputPDF As String
Dim DistJobOptions As String
Dim oldActivePrinter As String
Dim Repmonat As String
Dim Repmonat1 As String
Dim Repmonat2 As String
Dim RepBeginn As String
Dim RepEnd As String
Set myAdobeDist = New classAcroDist
Repmonat = Workbooks("MASTER_TEMPLATE.xls").Worksheets("Mdata").Range("B11")
Repmonat = Format(Repmonat, "mmm yyyy")
Repmonat1 = Workbooks("MASTER_TEMPLATE.xls").Worksheets("Mdata").Range("B2")
Repmonat1 = Format(Repmonat1, "mmm yyyy")
Repmonat2 = Workbooks("MASTER_TEMPLATE.xls").Worksheets("Mdata").Range("C2")
Repmonat2 = Format(Repmonat2, "mmm yyyy")
'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)
If Len(Dir("S:\PRODUKTION\ 2007\ARCHIV\" & Repmonat, vbDirectory)) = 0 Then
'MyPath = "S:\PRODUKTION\ 2007\ARCHIV\" & Repmonat
MkDir MyPath
Else
MyPath = "S:\PRODUKTION\2007\ARCHIV\" & Repmonat
End If
If Len(Dir("S:\PRODUKTION\2007\ARCHIV\" & Repmonat & "\" & (Repmonat1 & "-" & Repmonat2), _
vbDirectory)) = 0 Then
MyPath = "S:\PRODUKTION\2007\ARCHIV\" & Repmonat & "\" & (Repmonat1 & "-" & Repmonat2)
MkDir MyPath
Else
MyPath = "S:\PRODUKTION\2007\ARCHIV\" & Repmonat & "\" & (Repmonat1 & "-" & Repmonat2)
End If
'MyPath
'Pfad der Mappe extrahieren
strFileToPrintPfad = MyPath
'Dann wechsle vorher in den Pfad der Datei
ChDrive (Left(strFileToPrintPfad, 2))
ChDir MyPath
'Zur druckender: Mappenname_Tabelle1
' strFilename = strFileToPrintPfad & "\" & Left(myWB.Name, Len(myWB.Name) - 4) & "_" & " _
REPORTING" & " " & Repmonat
strFilename = strFileToPrintPfad & "\" & Left(myWB.Name, Len(myWB.Name) - 4) & " (" & ( _
Repmonat1 & "-" & Repmonat2) & ")"
'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.ActiveSheet.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 Not myAdobeDist.blnFinished Then
MsgBox "Fehler beim Druck in PDF Datei aufgetreten"
'MsgBox "PDF Printjob erfolgreich beended"
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
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
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