HasturSoft

module follows #################################################
Attribute VB_Name = "mdPDFCreator"
Option Explicit

' Benutzt folgendes Programm
' http://www.pdfforge.org/pdfcreator
' zum Ausdruck eines Objekts als PDF
' Getestet fuer pdfCreator 0.9.5
' Funktionen derzeit nur fuer MS-Excel definiert.
' Umbau der u.a. Makros fuer allgemeinere Druckfunktionen
' pdf/generer-un-pdf-par-macro-vba-sous-excel-t23.html

' AUSGABE IM DIREKTBEREICH
Private Const cTest_JN As Boolean = False

' BINDUNG ZUR LAUFZEIT
' Konstante gibt an, ob mit Verweis auf die Mirosoft Scripting Runtime (scrrun.dll)
' gearbeitet wird (cBindungZurLaufzeit=False), oder ueber Objekterstellung mittels
' CreateObject (cBindungZurLaufzeit=True), d.h. mit Bindung zur Laufzeit.
' Bei cBindungZurLaufzeit=False lassen sich die Eigenschaften/Methoden der Objekte der
' Scripting Runtime schoen uber den Objekt-'Punkt' (Object. ) aufrufen (fuer den
' Programmierer angenehmer), die Bindung zur Laufzeit laeuft aber sicherer.
#Const cBindungZurLaufzeit = True

' OBJEKTE DER MS SCRIPTING RUNTIME
#If cBindungZurLaufzeit = True Then
Private oFso As Object
Private oFile As Object
Private oStream As Object
Const ForReading = 1, ForWriting = 2, ForAppending = 3
Const TristateUseDefault = -2, TristateTrue = -1, TristateFalse = 0
#Else
Private oFso As Scripting.FileSystemObject
Private oFile As Scripting.File
Private oStream As Scripting.TextStream
#End If

' Beispiel
' #If cBindungZurLaufzeit = True Then
' Set oFso = CreateObject("Scripting.FileSystemObject")
' #Else
' Set oFso = New Scripting.FileSystemObject
' #End If

' OBJEKTE DES PDFCREATORS
#If cBindungZurLaufzeit = True Then
Private oPDFCreator As Object
#Else
Private oPDFCreator As PDFCreator.clsPDFCreator
#End If

' API Deklarationen
Private Declare Sub apiSleep Lib "kernel32.dll" Alias "Sleep" (ByVal dwMilliseconds As Long)

' SHELL EXECUTE
Private Declare Function apiShellExecute Lib "shell32.dll" _
Alias "ShellExecuteA" (ByVal hWnd As Long, _
ByVal lpOperation As String, ByVal lpFile As String, _
ByVal lpParameters As String, ByVal lpDirectory As String, _
ByVal nShowCmd As Long) As Long

' lpOperation Commands
Private Const apiNull As String = vbNullString

Private Const apiEDIT As String = "edit"
' Verhaelt sich so, als w¸rde man im Kontextmen¸ des Explorers auf
' "Bearbeiten" klicken.

Private Const apiEXPLORE As String = "explore"
' Handelt es sich bei "lpFile" um einen Verzeichnispfad,
' wird der Windows Explorer in Verbindung mit diesem Verzeichnis geoeffnet.

Private Const apiFIND As String = "find"
' Handelt es sich bei "lpFile" um einen Verzeichnispfad, wird der
' Windows Suchen-Dialog gestartet.

Private Const apiOPEN As String = "open"
' Oeffnet die Datei mit dem lt. Registry verknuepften Programm.

Private Const apiPRINT As String = "print"
' Druckt das Dokument in Verbindung mit der verknuepften Anwendung.

Private Const apiPROPERTIES As String = "properties"
'Zeigt die Verzeichnis- oder Datei-Eigenschaften

Private Const apiSW_HIDE = 0
Private Const apiSW_MAXIMIZE = 3
Private Const apiSW_MINIMIZE = 6
Private Const apiSW_NORMAL = 1
Private Const apiSW_SHOW = 5
Private Const apiSW_RESTORE = 9
Private Const apiSW_SHOWMAXIMIZED = 3
Private Const apiSW_SHOWMINIMIZED = 2
Private Const apiSW_SHOWMINNOACTIVE = 7
Private Const apiSW_SHOWNA = 8
Private Const apiSW_SHOWNOACTIVATE = 4
Private Const apiSW_SHOWNORMAL = 1

Private Const apiERROR_BAD_FORMAT = 11&
Private Const apiSE_ERR_ACCESSDENIED = 5
Private Const apiSE_ERR_ASSOCINCOMPLETE = 27
Private Const apiSE_ERR_DDEBUSY = 30
Private Const apiSE_ERR_DDEFAIL = 29
Private Const apiSE_ERR_DDETIMEOUT = 28
Private Const apiSE_ERR_DLLNOTFOUND = 32
Private Const apiSE_ERR_FNF = 2
Private Const apiSE_ERR_NOASSOC = 31
Private Const apiSE_ERR_OOM = 8
Private Const apiSE_ERR_PNF = 3
Private Const apiSE_ERR_SHARE = 26

' ADD TO RECENT DOC-LIST
Private Declare Sub apiSHAddToRecentDocs Lib "shell32.dll" _
Alias "SHAddToRecentDocs" (ByVal uFlags As Long, ByVal pv As String)
Private Const apiFlags As Long = &H2&


' SPECIAL FOLDER
Private Declare Function apiSHGetPathFromIDList Lib "Shell32" _
Alias "SHGetPathFromIDList" _
(ByVal lngIDList As Long, ByVal lpBuffer As String) As Long
Private Declare Function apiSHGetSpecialFolderLocation Lib "Shell32" _
Alias "SHGetSpecialFolderLocation" _
(ByVal hwndOwner As Long, ByVal nFolder As Integer, _
plngIDl As Long) As Long

Private Enum apiShellSpecialFolderConstants
tsDESKTOP = 0& 'Alle Ressourcen ab Desktop
tsProgramme = &H2& 'Startmen¸ Programme (aktueller Benutzer)
tsDrucker = &H4& 'Drucker
tsEigeneDateien = &H5& 'Eigene Dateien (aktueller Benutzer)
tsFavoriten = &H6& 'Favoriten (aktueller Benutzer)
tsSTARTMENU = &HB& 'Gesamtes Startmen¸ (aktueller Benutzer)
tsDesktopDir = &H10& 'Desktop (Ordner) (aktueller Benutzer)
tsArbeitsplatz = &H11& 'Arbeitsplatz
tsNetzwerkumgebung = &H12& 'Netzwerkumgebung
tsNetzwerkumgebungDir = &H13& 'Netzwerkumgebung (Ordner)
tsSchriften = &H14& 'Fonts (Ordner)
tsVorlagen = &H15& 'Vorlagen (Ordner)
tsGemStartmenu = &H16& 'Gesamtes Startmen¸ (alle Benutzer)
tsGemStartmenuPrg = &H17& 'Startmen¸ Programme (alle Benutzer)
tsGemAutostart = &H18& 'Autostart (Ordner) (alle Benutzer)
tsGemDesktopDir = &H18& 'Desktop (Ordner) (alle Benutzer)
tsAnwendungsdaten = &H1A& 'Anwendungsdaten (aktueller Benutzer)
tsDruckumgebungDir = &H1B& 'Druckumgebung (Ordner)
tsAltAutostart = &H1D& 'Altern. Autostart (Ordner) (aktueller Benutzer)
tsGemAltAutostart = &H1E& 'Altern. Autostart (Ordner) (alle Benutzer)
tsGemFavoriten = &H1F& 'Favoriten (alle Benutzer)
tsInternetCache = &H20& 'Temp. Internet Files
tsInternetCookies = &H21& 'Internet Cookies (Ordner)
tsInternetVerlauf = &H22& 'Internet Verlauf (Ordner)
End Enum

' Konstanten und Variablen
Private Const cTitel As String = "mdPDFCreator"
Private Const cWait As Double = 1000 ' Wartezeit
Private Const cStop_After As Long = 1000 ' Abbruchbedingung
Dim vRet As Variant

Private Sub mdPDFCreator_Testen()
' Call fctPDFCreator_Print(Excel.ActiveCell, , , True, True)
' Call fctPDFCreator_Print(ThisWorkbook.Sheets(1).Range("A3:A7"), , , True, True)
' Call fctPDFCreator_Print(ThisWorkbook, , , True, True)
' Eingebettetes CHART-Objekt
' Call fctPDFCreator_Print(ThisWorkbook.Worksheets(1).ChartObjects(1).Chart, , , True, True)
' SHEETS ARRAY
' Call fctPDFCreator_Print(ThisWorkbook.Sheets(Array("Tabelle1", "Tabelle2")), , , True, True)
' NICHT EXISTENTES VERZEICHNIS
' Call fctPDFCreator_Print(Excel.ActiveCell, "MUH", "O:\Mausibaerli\TomatenAufDenGuckern", True, True)
End Sub

Public Function fctPDFCreator_Print(ByRef oObject As Object, _
Optional ObjectName As String = "", _
Optional ObjectPath As String = "", _
Optional bOpenPDF As Boolean = False, _
Optional bMsgon As Boolean = False) As Boolean

' Prueft uebergebene Objekte/Werte, bzw. ob Bibliothek installiert
' wurde und uebergibt an Druckfunktion

Dim sName As String
Dim sTempName As String
Dim sMsg As String
Dim vPDF_FileName As Variant

If cTest_JN Then Debug.Print "Programmstart: ", Tab, Now

' Pruefung auf uebergebenes Objekt
If cTest_JN Then Debug.Print "Zum Druck uebergeben: ", Tab, VBA.TypeName(oObject)
Select Case VBA.TypeName(oObject)
' Befehl 'PrintOut' ist fuer folgende MS-Excel Objekte definiert:
Case "Chart", "Charts", "Sheets", "Window", "Workbook", "Worksheet", "Worksheets"
' Ausdruck moeglich
Case "Range"
' Wurde nur eine Zelle ausgewaehlt, wird das Worksheet, das die Zelle
' enthaelt, gedruckt.
If oObject.Cells.Count = 1 Then
Set oObject = oObject.Parent
End If
Case Else
' Objekt nicht druckbar oder Nothing
If bMsgon Then
On Error Resume Next
sName = oObject.Name
On Error GoTo 0
sMsg = "Objekt "
If sName <> "" Then sMsg = sMsg & sName & " "
sMsg = sMsg & "l‰sst sich nicht drucken!"
vRet = MsgBox(sMsg, vbCritical + vbOKOnly + vbSystemModal, cTitel)
End If
Exit Function
End Select

' Pruefung, ob Bibliothek pdfCreator installiert ist
On Error Resume Next
#If cBindungZurLaufzeit = True Then
Set oPDFCreator = CreateObject("PDFCreator.clsPDFCreator")
#Else
Set oPDFCreator = New PDFCreator.clsPDFCreator
#End If
On Error GoTo 0

If cTest_JN Then Debug.Print "Drucker: ", Tab, VBA.TypeName(oPDFCreator)

If VBA.TypeName(oPDFCreator) <> "clsPDFCreator" Then
If bMsgon Then
sMsg = "PDFCreator l‰sst sich nicht aufrufen!"
vRet = MsgBox(sMsg, vbCritical + vbOKOnly + vbSystemModal, cTitel)
End If
Set oPDFCreator = Nothing
Set oObject = Nothing
Exit Function
Else
If cTest_JN Then Debug.Print "Bibliothek: ", Tab, oPDFCreator.cPDFCreatorApplicationPath, oPDFCreator.cProgramRelease
End If

' Bestimmen des Dateinamens
If ObjectName = "" Then
Select Case VBA.TypeName(oObject)
Case "Chart"
ObjectName = oObject.Parent.Name & "_" & oObject.Name
Case "Charts"
ObjectName = oObject.Parent.Name & "_Charts"
Case "Window"
ObjectName = oObject.Caption
'ObjectName = oObject.SelectedSheets(1).Parent.Path
Case "Workbook"
ObjectName = oObject.Name
Case "Worksheet"
ObjectName = oObject.Parent.Name & "_" & oObject.Name
Case "Worksheets", "Sheets"
ObjectName = oObject.Parent.Name
Case "Range"
ObjectName = oObject.Address
ObjectName = Replace(ObjectName, ":", "-")
ObjectName = Replace(ObjectName, "$", "")
ObjectName = oObject.Parent.Parent.Name & "_" & _
oObject.Parent.Name & "_" & ObjectName
End Select
ObjectName = Replace(ObjectName, ".xls_", "_")
If UCase(Right(ObjectName, 4)) = ".XLS" Then ObjectName = Mid(ObjectName, 1, Len(ObjectName) - 4)
End If
If cTest_JN Then Debug.Print "Dateiname: ", Tab, ObjectName

' Bestimmen des Pfads
If ObjectPath = "" Then
Select Case VBA.TypeName(oObject)
Case "Window"
ObjectPath = oObject.SelectedSheets(1).Parent.Path
Case "Workbook"
ObjectPath = oObject.Path
Case "Worksheet", "Worksheets", "Sheets", "Charts"
ObjectPath = oObject.Parent.Path
Case "Chart"
ObjectPath = oObject.Parent.Parent.Parent.Path
Case "Range"
ObjectPath = oObject.Parent.Parent.Path
End Select
End If

' Pruefung ob Pfad existiert und Schreibrechte vorhanden
' wenn nicht, Desktop
If fctSchreibrecht_JN(ObjectPath) = False Then ObjectPath = fctGetSpecialFolder(tsDesktopDir)
' wenn nicht, Eigene Dateien
If fctSchreibrecht_JN(ObjectPath) = False Then ObjectPath = fctGetSpecialFolder(tsEigeneDateien)
' wenn nicht, TEMP
If fctSchreibrecht_JN(ObjectPath) = False Then
#If cBindungZurLaufzeit = True Then
Set oFso = CreateObject("Scripting.FileSystemObject")
#Else
Set oFso = New Scripting.FileSystemObject
#End If
' Scripting.SpecialFolderConst.TemporaryFolder
ObjectPath = oFso.GetSpecialFolder(2)
Set oFso = Nothing
End If

If cTest_JN Then Debug.Print "Pfad: ", Tab, ObjectPath

If fctSchreibrecht_JN(ObjectPath) = True Then
' Jetzt Uebergabe an die Druckfunktion
vPDF_FileName = fctPrint(oPDFCreator, oObject, ObjectName, ObjectPath, bMsgon)

If vPDF_FileName <> "" Then
fctPDFCreator_Print = True
If (cTest_JN Or bOpenPDF) Then
vRet = apiShellExecute(oObject.Application.hWnd, apiOPEN, vPDF_FileName, _
vbNull, vbNull, apiSW_SHOWNORMAL)
' Eintrag in Liste: letzte geoeffnete Dokumente
If bMsgon Then apiSHAddToRecentDocs apiFlags, vPDF_FileName
End If
vPDF_FileName = ""
'Excel.ThisWorkbook.FollowHyperlink (ObjectPath & Excel.Application.PathSeparator & ObjectName & ".pdf")
End If
Else
If bMsgon Then
sMsg = "Keine Schreibrechte, nicht einmal auf Desktop, Eigene Dateien oder TEMP!"
vRet = MsgBox(sMsg, vbCritical + vbOKOnly + vbSystemModal, cTitel)
End If

End If

Set oPDFCreator = Nothing
Set oObject = Nothing
If cTest_JN Then Debug.Print "Programmende: ", Tab, Now

End Function

Private Function fctGetSpecialFolder(FolderName As apiShellSpecialFolderConstants) As String
Dim lngID As Long
Dim strPath As String

Call apiSHGetSpecialFolderLocation(0, FolderName, lngID)

If lngID Then
strPath = Space(256)
Call apiSHGetPathFromIDList(lngID, strPath)
strPath = Left(strPath, InStr(strPath, Chr(0)) - 1)
Else
strPath = " - nicht definiert - "
End If
fctGetSpecialFolder = strPath

End Function

Private Function fctSchreibrecht_JN(ObjectPath As String) As Boolean
Dim sTempName As String

#If cBindungZurLaufzeit = True Then
Set oFso = CreateObject("Scripting.FileSystemObject")
#Else
Set oFso = New Scripting.FileSystemObject
#End If

With oFso
If .FolderExists(ObjectPath) Then
sTempName = .BuildPath(ObjectPath, .GetTempName)
On Error Resume Next
Set oStream = .CreateTextFile(sTempName)
If Err.Number <> 0 Then
' 70: Keine Schreibrechte
On Error GoTo 0
Else
On Error GoTo 0
oStream.Close
.DeleteFile FileSpec:=sTempName
fctSchreibrecht_JN = True
End If
End If
End With

Set oStream = Nothing
Set oFso = Nothing
End Function

Private Function fctPrint(PDFCreator1 As Object, _
oObject As Object, _
PDFName As String, _
PDFLocation As String, _
Optional bMsgon As Boolean = False) As String

' Eigentliche Druckfunktion, uebergibt den Dateinamen der PDF Datei

Dim sDefaultPrinter As String ' Imprimante par Defaut (memorisation)
Dim c As Long ' compteur Temporisation
Dim sOutputFilename As String ' Nom du Fichier Genere

' Initialisierung
If cTest_JN Then Debug.Print Tab, "INIT...";

With PDFCreator1
.cStart "/NoProcessingAtStartup"
.cOption("UseAutosave") = 1
.cOption("UseAutosaveDirectory") = 1
' Repertoire de stockage du Fichier PDF genere
.cOption("AutosaveDirectory") = PDFLocation
.cOption("AutosaveFilename") = PDFName
.cOption("AutosaveFormat") = 0 ' 0 = PDF
' Memorise l'Imprimante pas defaut
sDefaultPrinter = .cDefaultPrinter
' ecrase par PDFCreator
.cDefaultPrinter = "PDFCreator"
.cClearCache
End With

If cTest_JN Then Debug.Print "Druck..."
oObject.PrintOut Copies:=1, ActivePrinter:="PDFCreator"

If cTest_JN Then Debug.Print Tab, "Warten 1...";
' ABBRUCHBEDINGUNG FEHLT!
' Attend la Fin du travail pour quitter
c = 0
Do Until PDFCreator1.cCountOfPrintjobs = 1
c = c + 1
If c > cStop_After Then Exit Do
DoEvents
apiSleep cWait
Loop

apiSleep cWait
PDFCreator1.cPrinterStop = False
If cTest_JN Then Debug.Print "Drucker angehalten..."

If cTest_JN Then Debug.Print Tab, "Warten auf Datei";
c = 0
' Attend la Fin d'Ecriture au besoin 50x200ms (1 sec)
Do While (PDFCreator1.cOutputFilename = "") And (c < (cWait / 20))
c = c + 1
apiSleep (cWait / 5)
If cTest_JN Then Debug.Print ".";
Loop

If cTest_JN Then Debug.Print ""
' Recupere le nom du Fichier Genere
sOutputFilename = PDFCreator1.cOutputFilename
apiSleep (cWait / 5)

If cTest_JN Then Debug.Print Tab, "Ruecksetzen...";
With PDFCreator1
' Reattribue l'Imprimante initiale
If .cDefaultPrinter <> sDefaultPrinter Then
.cDefaultPrinter = sDefaultPrinter
End If
' Tempo de prise en compte avant fermeture
apiSleep (cWait / 2)
.cClose
End With
' Tempo 2 sec permettant d'assurer la liberation de PDFCreator de la Memoire
If cTest_JN Then Debug.Print "Warten 2..."
apiSleep (cWait * 2)

If sOutputFilename = "" Then
If bMsgon Then
vRet = MsgBox("CrÈation Fichier pdf." & vbCrLf & vbCrLf & _
"Une Erreur s'est produite: DÈlai dÈpassÈ!", vbExclamation + vbSystemModal, cTitel)
End If
Else
If cTest_JN Then Debug.Print Tab, "Ausgabedatei: " & sOutputFilename
fctPrint = sOutputFilename
End If
End Function

end of module ###################################################