VBA - pdf Anhänge im Unterordner drucken

[hal.lore]

Moin,

ich habe ein Makro von vor langer Zeit gefunden:

Sub Drucken()

Dim fso As Object
Dim objPosteingang As MAPIFolder
Dim objNewMail As MailItem
Dim olSelection As Selection
Dim olitem
Dim sFileType As String
Dim Dokument As String

Dim strNewFolder As String
Dim intAnlagen As Integer
Dim i As Integer
Dim FolderPath As String
Dim DateFolderPath As String


Set olSelection = Application.ActiveExplorer.Selection


' Hier Zielordner festlegen
FolderPath = "D:Temp"
DateFolderPath = FolderPath & "" & Format(Date, "yyyy-mm-dd")

Set fso = CreateObject("Scripting.FileSystemObject")

If Not fso.FolderExists(FolderPath) Then
fso.CreateFolder FolderPath
End If

If Not fso.FolderExists(DateFolderPath) Then
fso.CreateFolder DateFolderPath
End If

For Each objNewMail In olSelection
With objNewMail
intAnlagen = .Attachments.Count
If intAnlagen > 0 Then
For i = 1 To intAnlagen
sFileType = LCase$(Right$(.Attachments.Item(i).FileName, 4))
Select Case sFileType
Case "docx", ".doc"
If Not fso.fileexists(FolderPath & "" & .Attachments.Item(i).FileName) Then
.Attachments.Item(i).SaveAsFile FolderPath & "" & .Attachments.Item(i).FileName
Dokument = FolderPath & "" & .Attachments.Item(i).FileName
Drucken22 Dokument
Kill Dokument
End If

End Select

Next i
End If

End With

Next objNewMail
Set fso = Nothing



End Sub

Private Sub Drucken22(Dokument As String)

Dim Datum
Datum = Format(Date, "YYYY")

'Create a Word object
Dim wrdApp As Word.Application
Dim wrdDoc As Word.Document
Set wrdApp = CreateObject("Word.Application")

'Open the mht-file in Word without Word visible
Set wrdDoc = wrdApp.Documents.Open(FileName:=Dokument, Visible:=True)

'Define the SafeAs dialog
Dim dlgSaveAs As FileDialog
Set dlgSaveAs = wrdApp.FileDialog(msoFileDialogSaveAs)

'Determine the FilterIndex for saving as a pdf-file
'Get all the filters
Dim fdfs As FileDialogFilters
Dim fdf As FileDialogFilter
Set fdfs = dlgSaveAs.Filters

'Loop through the Filters and exit when "pdf" is found
Dim a As Integer
i = 0
For Each fdf In fdfs
i = i + 1
If InStr(1, fdf.Extensions, "pdf", vbTextCompare) > 0 Then
Exit For
End If
Next fdf

'Set the FilterIndex to pdf-files
dlgSaveAs.FilterIndex = i

'Get location of My Documents folder
Dim WshShell As Object
Dim SpecialPath As String
Set WshShell = CreateObject("WScript.Shell")
SpecialPath = WshShell.SpecialFolders(16)


SpecialPath = SpecialPath & "Temp"


'Construct a safe file name from the message subject
Dim msgFileName As String
'Zwischenablage auslesen
'nClipboardText.GetFromClipboard
'oltext = nClipboardText.GetText(1)
'Überprüfen ob Zwischenablage TicketID enthält
'zaehlen = Len(oltext)
'If zaehlen = 11 Then
'msgFileName = oltext & " / " & MySelectedItem.Subject
'Else
msgFileName = Datum & "-00"
'End If



Set oRegEx = CreateObject("vbscript.regexp")
oRegEx.Global = True
oRegEx.Pattern = "[/:*?""<>|]"
msgFileName = Trim(oRegEx.Replace(msgFileName, ""))

'Set the initial location and file name for SaveAs dialog
Dim strCurrentFile As String
dlgSaveAs.InitialFileName = SpecialPath & msgFileName

'Show the SaveAs dialog and save the message as pdf
If dlgSaveAs.Show = -1 Then
strCurrentFile = dlgSaveAs.SelectedItems(1)

'Verify if pdf is selected
If Right(strCurrentFile, 4) <> ".pdf" Then
Response = MsgBox("Sorry, nur das speichern als PDF wird unterstützt." & _
vbNewLine & vbNewLine & "Jetzt als PDF speichern?", vbInformation + vbOKCancel)
If Response = vbCancel Then
wrdDoc.Close
wrdApp.Quit
Exit Sub
ElseIf Response = vbOK Then
intPos = InStrRev(strCurrentFile, ".")
If intPos > 0 Then
strCurrentFile = Left(strCurrentFile, intPos - 1)
End If

strCurrentFile = strCurrentFile & ".pdf"
End If
End If

'Save as pdf
wrdApp.ActiveDocument.ExportAsFixedFormat OutputFileName:= _
strCurrentFile, ExportFormat:= _
wdExportFormatPDF, OpenAfterExport:=False, OptimizeFor:= _
wdExportOptimizeForPrint, Range:=wdExportAllDocument, From:=0, To:=0, _
Item:=wdExportDocumentContent, IncludeDocProps:=True, KeepIRM:=True, _
CreateBookmarks:=wdExportCreateNoBookmarks, DocStructureTags:=True, _
BitmapMissingFonts:=True, UseISO19005_1:=False
End If
Set dlgSaveAs = Nothing

' close the document and Word
wrdDoc.Close
wrdApp.Quit

'Cleanup
Set MyOlNamespace = Nothing
Set MyOlSelection = Nothing
Set MySelectedItem = Nothing
Set wrdDoc = Nothing
Set wrdApp = Nothing
Set oRegEx = Nothing


Ende:

End Sub


Das macht schon viel in meine Richtung.
Aber ich möchte, dass das nur in einem Unterordner /Posteingang/Firmen/1_Rechnungen ausgeführt wird.

Wo muss ich das eintragen?

Vielen Dank
hal.lore

[markusxy]

Wenn du Hilfe willst, sollte du solche Aktionen unterlassen.
Code ist schwer lesbar, wenn er nicht in Code Tags gepackt wird.
Es ist außerdem eine Zumutung Kilometerlange Codes zu posten, bei denen es nicht um das Problem geht. Andere haben ihre Zeit auch nicht gestohlen.

Poste also nur den Code der das Problem betrifft - oder heben den Code farblich erkennbar hervor - und das ordentlich formatiert.

[EarlFred]

Hallo,

mit folgenden Änderungen sollte es klappen:

Code:

Dim olSelection As Outlook.Items

Set olSelection = Session.GetDefaultFolder(olFolderInbox).Folders("Firmen").Folders("1_Rechnungen").Items

Grüße
EarlFred

[hal.lore]

Lieben Dank erstmal,

ich werde es ausprobieren

hal.lore

[hal.lore]

Hallo EarlFred,

es klappt (zumindest teilweise).
Der Temp-Ordner wird erstellt, aber danach scheint nichts weiter zu passieren

Stelle ich alles auf Anfang zurück, funktioniert es eigentlich korrekt, aber druckt natürlich den kompletten Urwald leer

hal.lore (leicht verwirrt)