![]() |
|
![]() |
#1 |
![]() Neuer Benutzer |
![]() 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 |
![]() |
![]() ![]() |
![]() |
#2 |
![]() MOF Meister |
![]() 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. |
![]() |
![]() ![]() |
![]() |
#3 |
![]() MOF Guru |
![]() Hallo,
mit folgenden Änderungen sollte es klappen: Code: Dim olSelection As Outlook.Items Set olSelection = Session.GetDefaultFolder(olFolderInbox).Folders("Firmen").Folders("1_Rechnungen").Items EarlFred __________________ Datum und Uhrzeit, Makrorekorder-Code entschlacken, {Matrixformeln}Tutorials zu Pivottabellen: Kurzeinstieg; Dynamischer Datenbereich; Daten und Zeiten gruppieren Für 7 meiner Beiträge haben sich die Hilfesuchenden mit einer Spende an Wikipedia, die Tafeln oder Hilfe für krebskranke Kinder eV bedankt (das entspricht 0,049% per 19.12.2018) - eine tolle Geste! |
![]() |
![]() ![]() |
![]() |
#4 |
Threadstarter
![]() ![]() Neuer Benutzer |
![]() Lieben Dank erstmal,
ich werde es ausprobieren ![]() hal.lore |
![]() |
![]() ![]() |
![]() |
#5 |
Threadstarter
![]() ![]() Neuer Benutzer |
![]() 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) |
![]() |
![]() ![]() |