Ghostscript --> FreePDF --> VBA --> Excel (Programmierung / Office/Excel)

Hallo Zusammen,

ich habe zuerst den Ghostscript, dann den FreePDF XP bei mir installiert.
Ich würde gerne in Excel über VBA eine Tabelle automatisch mit der Dateiname, der in einer Zeile steht, abspeichern.

Ich habe im Internet folgende Code getestet:

Sub Makro1_PDF_Drucker()

Range("a1:j53").Select

Neuname1 = ThisWorkbook.Sheets("Tabelle1").Range("D16")

Name = Left$("0000", 4 - Len(Neuname1)) & Neuname1

ActiveSheet.Copy

ActiveWorkbook.SaveAs Filename:="D:\Eigene Dateien\4_Rechnungen\Excel_Datei_Rechnungen\" & Name & ".xls"
ActiveWindow.SelectedSheets.PrintOut Copies:=2, Collate:=True
Application.ActivePrinter = "FreePDF auf Ne09:"
Selection.PrintOut Copies:=1, ActivePrinter:="FreePDF auf Ne09:", _
Collate:=True

ActiveWorkbook.Close

End Sub

Ergebnis:
=========
Hier kann ich zwar den "Drucker" FreePDF ansprechen, aber hier geht auch das Dialogfenster auf, wo ich sagen muß, wo er die PDF abspeichern soll. Denn gewünschten Dateinamen schreibt er schon in das Dialog rein.
Hier ist aber auch, dass er dieses Makro nicht auf einem anderen rechner ausführt, weil er dann FreePDF auf Ne02:" statt FreePDF auf Ne09:" verlangt.

Ich habe auch einen zweiten Beitrag gefunden:
....................=======..................

1. Richte ein Multidoc-Drucker ein.
a) Erstelle ein neues Profil, mit der Eigenschaft:
FreePDF Dialog: Aktion beim Drucken = Multi Document Button
Speichere das Profil als: FreePDF_Multidoc

   b) Erstelle einen neuen Druckeranschluss mit den den
Argument für diese Programm (in einer Zeile):
   C:\Programme\FreePDF_XP\fpRedMon.exe
   profile=FreePDF_Multidoc %1
   Speichere den Drucker als FreePDF_Multidoc

2. Verwende folgende allgemeinen Hilfsroutinen (VB-Codes):

Public 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

' API Declaration
Public Declare Function GetTickCount Lib "kernel32" () As Long

Private Declare Function ShellExecute 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

Function GetMyDocumentsFolder() As String
'Sucht den Ordner 'Eigene Dateien' unter WinXP

Dim wshshell As Object
Dim struser As String
Set wshshell = CreateObject("Wscript.shell")

struser = wshshell.SpecialFolders("MyDocuments")
GetMyDocumentsFolder = struser
End Function

Public Function Convert_PSFile(Optional sZiel As String = "c:\temp\tmp.pdf") As Boolean
Dim sFilePS As String, sFilePDF As String, stmpPS As String
Dim result As Long

10 On Error GoTo Convert_PSFile_Error

20 stmpPS = Dir("C:\Documents and Settings\All Users\FreePDF\*.ps")

30 If stmpPS = "" Or InStr(1, stmpPS, "~", vbTextCompare) <> 0 Then
'Beim drucken wird eine Dummy mit ~ eingerichtet. Daher Abbruch
40 Convert_PSFile = False
50 Exit Function
60 Else
70 Convert_PSFile = True
80 End If

120 sFilePDF = sZiel

140   Do While stmpPS <> ""
150    sFilePS = sFilePS & "C:\Documents and Settings\All Users\FreePDF\" & stmpPS & """ """
160    stmpPS = Dir
170   Loop

180   result = PS2PDf(Left(sFilePS, Len(sFilePS) - 1), sFilePDF)

'Aufräumen FreePDF-Verzweichnis
190   stmpPS = Dir("C:\Documents and Settings\All Users\FreePDF\*.ps")
200   Do While stmpPS <> ""
210    Kill "C:\Documents and Settings\All Users\FreePDF\" & stmpPS
220    stmpPS = Dir
230   Loop

240 On Error GoTo 0
250 Exit Function

Convert_PSFile_Error:

260 MsgBox "Fehlernr.: " & Err.Number & " (" & Err.Description & ") in Prozedur Convert_PSFile von Modul mdlpdftk", , "Fehler in Zeile: " & Erl

End Function

Public Function PS2PDf(psFile As String, pdfFile As String) As Boolean
Dim FreePDF
10 On Error GoTo PS2PDf_Error

'FreePDF festlegen
20 FreePDF = Environ("programfiles") & "\freepdf_xp\freepdf.exe"
'Prüfen, ob FreePDF vorhanden ist
30 If Dir(FreePDF) <> "" Then
'FreePDF aufrufen

40 If ShellAndWait(FreePDF & " /3 delps,end ""eBook"" " & """" & pdfFile & """ """ & psFile) = 0 Then
'Aufruf erfolgreich
50 PS2PDf = True
60 End If
70 Else
80 MsgBox "FreePDF ist nicht unter " & FreePDF & ""
installiert ", vbExclamation"
90 End If

100 On Error GoTo 0
110 Exit Function

PS2PDf_Error:

120 MsgBox "Fehlernr.: " & Err.Number & " (" & Err.Description & ") in Prozedur PS2PDf von Modul mdlpdftk", , "Fehler in Zeile: " & Erl
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

10 On Error GoTo ShellAndWait_Error

20 On Error GoTo ShellAndWait_Error

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

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

100 Call CloseHandle(hProcess)

110 ShellAndWait = exitCode

120 On Error GoTo 0
130 Exit Function

ShellAndWait_Error:

140 MsgBox "Fehlernr.: " & Err.Number & " (" & Err.Description & ") in Prozedur ShellAndWait von Modul mdlpdftk", , "Fehler in Zeile: " & Erl

End Function

Public Sub tmp_Aufräumen()
Dim tmp As String
10 On Error GoTo tmp_Aufräumen_Error

20 tmp = Dir("c:\temp\" & "*.*")

30 Do While tmp <> ""
40 Kill "c:\temp\" & tmp
50 tmp = Dir
60 Loop

70 On Error GoTo 0
80 Exit Sub

tmp_Aufräumen_Error:

90 MsgBox "Fehlernr.: " & Err.Number & " (" & Err.Description & ") in Prozedur tmp_Aufräumen von Modul mdlpdftk", , "Fehler in Zeile: " & Erl

End Sub

'3. Aufgerufen wird das ganze wie folgt:

End Sub

Private Sub UserForm_Click()

Dim Old_Drucker As String, Multidoc As String
Dim tmpName As String, tmpPfad As String
10 Old_Drucker = Application.ActivePrinter

Application.ActivePrinter = "FreePDF_Multidoc"
ActiveWindow.SelectedSheets.PrintOut Copies:=Count
Application.ActivePrinter = Old_Drucker

tmpName = ActiveSheet.Range("A1").Text 'Dateiname in Zelle A1
tmpName = GetMyDocumentsFolder() & "\" & tmpName

If Convert_PSFile(tmpName) = True Then
MsgBox "Alles i.O."
Else
MsgBox "Fehler!"
End If
End Sub

Ergebnis:
=========
Ich habe auch ein neues Profil und den Drucker wie beschrieben angelegt.
Führe ich das Programm aus, kann er mit den beiden Zeilen nichts anfangen:

Zeile 1:Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Zeile 5:Public Declare Function GetTickCount Lib "kernel32" () As Long

==============================================================

Kann mir hier vielleicht jemand weiterhelfen ?

------------------
Schöne Grüße
Feyza : )

[Diese Nachricht wurde von Feyza am 18. Jul. 2007 editiert.]

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP