Option Compare Database
Option Explicit

''Aufruf der Doc2PDF Funktion
'x = Doc2PDF("C:\test.doc", "C:\doc.pdf")

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare Function OpenProcess Lib "kernel32" _
      (ByVal dwDesiredAccess As Long, _
      ByVal bInheritHandle As Long, _
      ByVal dwProcessId As Long) As Long
Private Declare Function GetExitCodeProcess Lib "kernel32" _
      (ByVal hProcess As Long, lpExitCode As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" _
      (ByVal hObject As Long) As Long


Public Function Doc2PDF(WordDocument As String, PDFDocument As String) As Boolean
' Dieses Beispiel druckt ein Word-Dokument auf dem FreePDF Drucker aus und
' ffnet es dann zur Umwandlung mit FreePDF
Dim psFile As String
Dim Application As Object, OldPrinter

'Name der Temporren PostScript Datei
psFile = PDFDocument & ".ps"

'Word-Prozess ffnen
Set Application = CreateObject("Word.Application")

With Application
    'Standart Drucker im Word sichern
    OldPrinter = Application.ActivePrinter
    'Drucker "FreePDF XP" einstellen
    .ActivePrinter = "FreePDF XP"
    'Dokument ffnen
    .Documents.Open WordDocument, False, True
    'Document in Datei drucken
    '.PrintOut 0, 0, 0, psFile
    .PrintOut 0, 0, 0, psFile, , , , , , , True
    '"Drucken in Datei" zurcksetzen:
    .PrintOut , , 4, , , , , , "0", , False
    'Document schlieen
    .Documents.Close False
    'Drucker zurckstellen
    .ActivePrinter = OldPrinter
    'Word beenden
    .Quit
End With
'Word-Prozess wieder beenden
Set Application = Nothing

If Dir(psFile) <> "" Then
    Dim FreePDF
    'FreePDF festlegen
    FreePDF = Environ("programfiles") & "\freepdf_xp\freepdf.exe"
    'Prfen, ob FreePDF vorhanden ist
    If Dir(FreePDF) <> "" Then
        'FreePDF aufrufen
        If ShellAndWait(FreePDF & " /3 delps,end ""eBook"" " & """" & PDFDocument & """ """ & psFile & """") = 0 Then
            'Aufruf erfolgreich
            Doc2PDF = True
        End If
    Else
        MsgBox "FreePDF ist nicht unter " & FreePDF & " installiert", vbExclamation
    End If
End If
End Function

Public Function ps2PDF(psFile As String, pdfFile As String) As Boolean
If Dir(psFile) <> "" Then
    Dim FreePDF
    'FreePDF festlegen
    FreePDF = Environ("programfiles") & "\freepdf_xp\freepdf.exe"
    'Prfen, ob FreePDF vorhanden ist
    If Dir(FreePDF) <> "" Then
        'FreePDF aufrufen
        If ShellAndWait(FreePDF & " /3 delps,end ""eBook"" " & """" & pdfFile & """ """ & psFile & """") = 0 Then
            'Aufruf erfolgreich
            ps2PDF = True
        End If
    Else
        MsgBox "FreePDF ist nicht unter " & FreePDF & " installiert", vbExclamation
    End If
End If
End Function


Private Function ShellAndWait(Befehl As String) As Integer ', Optional WindowStyle As VbAppWinStyle = vbNormalFocus
Dim hProcess As Long
Dim ProcessId As Long
Dim exitCode As Long
Dim x, y

ProcessId = Shell(Befehl, vbNormalFocus)
hProcess = OpenProcess(&H400, False, ProcessId)

Do  'Warten auf Ende der Konvertierung
    Call GetExitCodeProcess(hProcess, exitCode)
    '0,5 Sekunden Warten:
    DoEvents
    Sleep 500
Loop While exitCode = &H103&

Call CloseHandle(hProcess)

ShellAndWait = exitCode
End Function





