AW: automatisches Erstellen von pdf
07.08.2008 17:38:00
pdf
Hallo,
hier der code
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(Sheets("Focus1"), "testBallon")
End Sub
Public Sub Print_to_PDF(tarWks As Worksheet, strNewDateiname As String)
'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 myWS As Worksheet
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)
'Worksheeet zuweisen
Set myWS = tarWks
'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
strFilename = strFileToPrintPfad & "\" & strNewDateiname
'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"
myWS.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
'***nichts tun
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
Sub procAusdruckStarten(temp_tarWks As Worksheet, tempNewDateiname As String)
Call Print_to_PDF(temp_tarWks, tempNewDateiname)
Application.Wait Now + TimeValue("00:00:01")
End Sub