MS-Office-Forum

Zurück   MS-Office-Forum > Microsoft Office > Microsoft Outlook (Express), sonst. Mailprogramme
Registrieren Forum Hilfe Alle Foren als gelesen markieren

Banner und Co.

Antworten
Ads
Themen-Optionen Ansicht
Alt 04.12.2018, 16:01   #1
hal.lore
Neuer Benutzer
Neuer Benutzer
Standard VBA - 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
hal.lore ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 05.12.2018, 12:45   #2
markusxy
MOF Meister
MOF Meister
Standard

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.
markusxy ist gerade online  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 05.12.2018, 14:04   #3
EarlFred
MOF Guru
MOF Guru
Standard

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

__________________

Datum und Uhrzeit, Makrorekorder-Code entschlacken, {Matrixformeln}
Tutorials zu Pivottabellen: Kurzeinstieg; Dynamischer Datenbereich; Daten und Zeiten gruppieren
Für 6 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,044% per 26.07.2018) - eine tolle Geste!
EarlFred ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 06.12.2018, 08:21   #4
hal.lore
Threadstarter Threadstarter
Neuer Benutzer
Neuer Benutzer
Standard

Lieben Dank erstmal,

ich werde es ausprobieren

hal.lore
hal.lore ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 07.12.2018, 13:05   #5
hal.lore
Threadstarter Threadstarter
Neuer Benutzer
Neuer Benutzer
Standard

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)
hal.lore ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Ads
Antworten


Aktive Benutzer in diesem Thema: 1 (Registrierte Benutzer: 0, Besucher: 1)
 
Themen-Optionen
Ansicht

Forumregeln
Es ist Ihnen nicht erlaubt, neue Themen zu verfassen.
Es ist Ihnen nicht erlaubt, auf Beiträge zu antworten.
Es ist Ihnen nicht erlaubt, Anhänge anzufügen.
Es ist Ihnen nicht erlaubt, Ihre Beiträge zu bearbeiten.

vB Code ist An.
Smileys sind An.
[IMG] Code ist An.
HTML-Code ist An.
Gehe zu


Alle Zeitangaben in WEZ +1. Es ist jetzt 21:05 Uhr.


Partner und Co.
Access-Paradies -Alles rund um die Datenbank Microsoft Access -Code -Programme-Tools -Tipps   Kostenlose Tipps & Tricks, Downloads und Programme   www.kulpa-online.com - Tipps - Tricks - Tutorials - Meinungen - Downloads uvm...   vb@rchiv · Willkommen in der Welt der VB Programmierung   Access-Garhammer - Hier finden Sie jede Menge Beispiel-Datenbanken zu Access und mehr ...   mcseboard.de   Die Top Seite für Excel-VBA-Makros uvm.

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

Copyright ©2000-2018 MS-Office-Forum. Alle Rechte vorbehalten.
Copyright ©Design: Manuela Kulpa ©Rechte: Günter Kramer
Eine Verwendung der Inhalte in anderen Publikationen, auch auszugsweise,
ist ohne ausdrückliche Zustimmung der Autoren nicht gestattet.