Microsoft Excel

Herbers Excel/VBA-Archiv

Informationen und Beispiele zum Thema MsgBox
BildScreenshot zu MsgBox MsgBox-Seite mit Beispielarbeitsmappe aufrufen
Informationen und Beispiele zum Thema CommandButton
BildScreenshot zu CommandButton CommandButton-Seite mit Beispielarbeitsmappe aufrufen

automatisch Dateiname.pdf generieren | Herbers Excel-Forum


Betrifft: automatisch Dateiname.pdf generieren von: Benedikt
Geschrieben am: 28.02.2010 17:02:39

Hi alle zusammen,

Mein Problem ist, dass ich aus einem Excel-Worksheet per Click auf CommandButton eine pdf-Datei generieren will. Das funktioniert auch, nur würde ich gerne den Dateiname vom entstandenen pdf vom User über eine Textbox erzeugen lassen. Dieser Name sollte sich dann wie folgt zusammen setzen:

COS_"die vom Benutzer über Textbox eingegebene Zahlenkombi".pdf

Dies muss der User bis jetzt noch direkt über das Windowsfenster nach der pdf-Erzeugung selbst machen. Hierbei wird auch noch nach dem Speicherort gefragt.

Beides soll nun automatisch im Hintergrund ablaufen, und zwar:

1) Dateiname generieren
2) Speicherort festlegen
3) danach automatisch speichern unter gewählten Namen/Speicherort

Mein bisheriger Code:

'PDF generieren

Range("A1:S96").Select 'Range im Worksheet definiert Formular
Worksheets("Formular").PageSetup.PrintArea = "$A$1:$S$96"
Application.ActivePrinter = "Adobe PDF auf Ne02:"
Worksheets("Formular").PrintOut Copies:=1, ActivePrinter:= _
"Adobe PDF auf Ne02:", Collate:=True

Ich wäre dankbar über jede Zeile Code, die mir weiterhilft!!

Grüße und Danke im Voraus

Benny

  

Betrifft: AW: automatisch Dateiname.pdf generieren von: Ramses
Geschrieben am: 28.02.2010 17:31:46

Hallo

Der Code dazu ist umfangreicher als du vielleicht denkst

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
'**********************************************
'Mit dieser Sequenz wird der Ausdruck gestartet
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)
    '(C) 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)
    '(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)
            Exit For
        End If
    Next
End Function


'Nur zur Entwicklung nötig
Public Sub Print_PrinterList()
    '(C) by Ramses
    'gibt alle installierten Drucker im Debug.Fenster aus
    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 - 1
        'If InStr(1, strPrinterNames(intIndex), "Adobe") > 0 Then
        Debug.Print strPrinterNames(intIndex) & " auf " & strPrinterPorts(intIndex)
        'End If
    Next intIndex
End Sub

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

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)
        End If
    End If
End Sub


'************************
'Das gehört in ein Klassenmodul deiner Arbeitsmappe mit dem Namen
'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
    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



Info:

'Pfad der Mappe extrahieren
strFileToPrintPfad = myWB.Path

Druckt das PDF File in das Verzeichnis der aktuellen Arbeitsmappe, alternativ den Pfad entsprechend anpassen wenn das woanders hin soll.

Gruss Rainer


  

Betrifft: AW: automatisch Dateiname.pdf generieren von: Benedikt
Geschrieben am: 28.02.2010 20:10:35

@ Ramses:

Ach du scheiße, ist das riesig...ich probiers gleich morgen mal aus und würd mich dann gegebenenfalls wieder melden ;)

Grüße Benny


Beiträge aus den Excel-Beispielen zum Thema "automatisch Dateiname.pdf generieren"