MS-Office-Forum

MS-Office-Forum (https://www.ms-office-forum.net/forum/index.php)
-   Microsoft Outlook (Express), sonst. Mailprogramme (https://www.ms-office-forum.net/forum/forumdisplay.php?f=32)
-   -   pdf Anhänge im Unterordner drucken (https://www.ms-office-forum.net/forum/showthread.php?t=356238)

hal.lore 04.12.2018 15:01

pdf Anhänge im Unterordner drucken
 
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 05.12.2018 11:45

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 05.12.2018 13:04

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 06.12.2018 07:21

Lieben Dank erstmal,

ich werde es ausprobieren :)

hal.lore

hal.lore 07.12.2018 12:05

Hallo EarlFred,

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

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

hal.lore (leicht verwirrt)


Alle Zeitangaben in WEZ +1. Es ist jetzt 17:55 Uhr.

Powered by: vBulletin Version 3.6.2 (Deutsch)
Copyright ©2000 - 2019, Jelsoft Enterprises Ltd.