AW: PDF-Dateien in Ordner über Microsoft Print to PDF speichern
25.12.2025 13:01:52
volti
Hallo Bernd,
grundsätzlich ist es oft möglich, einer Textbox in einem externen Dialog ("Druckausgabe speichern unter") einen Text vorzugeben und anschließend einen Button, z.B. Speichern anzuklicken.
Hierzu benötigt man spezielle API-Funktionen. Wegen des komplizierten zeitlichen Ablaufs ist das aber etwas heikel.
Es erscheint z.B. ein weiterer Dialog, wenn es die Datei schon gibt, usw..
Hier mal eine Idee, aufgesetzt auf Deinen bisherigen code. Probiere es einfach mal aus, vielleicht klappt es ja. Ist aber nur wenig getestet.
Bei mir wird übrigens die Adobe.Exe nicht wieder geschlossen (taskkill)
Private Declare PtrSafe Function ShellExecuteA Lib "shell32.dll" ( _
ByVal hWnd As LongPtr, ByVal lpOperation As String, ByVal lpFile As String, _
ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As LongPtr
Private Declare PtrSafe Function SetTimer Lib "user32" ( _
ByVal hWnd As LongPtr, ByVal nIDEvent As LongPtr, _
ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
Private Declare PtrSafe Function KillTimer Lib "user32" ( _
ByVal hWnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
Private Declare PtrSafe Function FindWindowA Lib "user32" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function SendDlgItemMessageA Lib "user32" ( _
ByVal hDlg As LongPtr, ByVal nIDDlgItem As Long, _
ByVal wMsg As Long, ByVal wParam As LongPtr, _
ByVal lParam As LongPtr) As LongPtr
Private Declare PtrSafe Function EnumChildWindows Lib "user32" ( _
ByVal hWndParent As LongPtr, ByVal lpEnumFunc As LongPtr, _
ByVal lParam As LongPtr) As Long
Private Declare PtrSafe Function SendMessageA Lib "user32" ( _
ByVal hWnd As LongPtr, ByVal wMsg As Long, _
ByVal wParam As LongPtr, lParam As Any) As LongPtr
Private Declare PtrSafe Function GetDlgCtrlID Lib "user32" ( _
ByVal hWnd As LongPtr) As Long
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Const BM_CLICK As Long = &HF5
Private Const WM_SETTEXT As Long = &HC
Dim mhTimer As LongPtr, mi As Long
Dim msDateiPfadNeu As String
Sub PrintPDFFiles()
Dim FolderPath As String, FileName As String, PDFPath As String, Speicherpfad As String
'Your PDF files are located
FolderPath = ThisWorkbook.Path & "\"
' Loop All files in the folder
FileName = Dir(FolderPath & "*" & ".pdf")
Do While FileName > ""
PDFPath = FolderPath & FileName
' Speichern-Dialog füllen
mi = 0
Speicherpfad = "D:\Test\" ' ggf. anpassen >>>
msDateiPfadNeu = Speicherpfad & "NEUPDF_" & FileName
If Dir(msDateiPfadNeu) > "" Then Kill msDateiPfadNeu ' vorhandene Datei löschen
mhTimer = SetTimer(0&, 0&, 100, AddressOf PrintPDF_CallbackProc)
If ShellExecuteA(Application.hWnd, "Print", PDFPath, vbNullString, vbNullString, 3) = 32 Then
KillTimer 0&, mhTimer: mhTimer = 0
MsgBox "Failed to print " & PDFPath
Else
' Adjust the duration as needed
Application.Wait Now + TimeValue("00:00:05")
Call Shell("taskkill /f /im AcroRd32.exe", vbHide)
End If
FileName = Dir
Loop
End Sub
Sub PrintPDF_CallbackProc()
Dim hDlg As LongPtr, sTxt As String * 10
mi = mi + 1
hDlg = FindWindowA(vbNullString, "Druckausgabe speichern unter")
If mi > 50 Or hDlg > 0 Then KillTimer 0&, mhTimer: mhTimer = 0 ' Timer löschen, wenn Dlg gefunden
If hDlg > 0 Then
Sleep 500
EnumChildWindows hDlg, AddressOf EnumControls, 0
DoEvents
SendDlgItemMessageA hDlg, 1, BM_CLICK, ByVal 0, ByVal 0 ' Speicher-Button ID=1 klicken
End If
End Sub
Private Function EnumControls(ByVal hChild As LongPtr, ByVal lParam As LongPtr) As Long
' Function ermittelt anhand der ID die richtige Textbox (Edit) und setzt den Text ein
EnumControls = True
If GetDlgCtrlID(hChild) = 1001 Then ' 1001=ID der Editbox
SendMessageA hChild, WM_SETTEXT, 0, ByVal msDateiPfadNeu ' Text einsetzen
EnumControls = False
End If
End Function
Gruß
Karl-Heinz