Outlook PDFs speichern, drucken und verschieben

Moderator: ModerationP

Outlook PDFs speichern, drucken und verschieben

Beitragvon SDAU_Jens » 19. Jun 2019, 09:29

Hallo zusammen,

ich würde gerne ein kleines VBA-Makro basteln, das folgende Funktionen bereithält:
1. Speichern aller (und zwar unabbhängig von der Schreibweise) PDF-Anhänge in selektierten Mails in absenderdomänenbasierten Ordnern
2. Erweiterung des Dateinamens um das Empfangsdatum
3. Drucken des Anhangs
4. Verschieben der Mail in den Mailordner "Eingangsarchiv"

Dazu habe ich mir untenstehendes Script zusammen gebastelt und kopiert.

Folgende Probleme treten auf:
- Die Speichern/Drucken Aktion wird nicht bei allen selektierten Mails durchgeführt - habe schon rausgefunden, dass ich .PDF und .pdf gesondert abfragen muss - noch was?
- Es werden statt z.B. 5 selektierten Mails beim move etliche Mails mehr in den Rechnungsarchiv verschoben - einige dabei dupliziert.

Kann mir jemand nachhelfen? Bin da noch recht grün hinter den Ohren...

Lieben Dank und lieben Gruß

Jens
Code: Alles auswählen
Private Declare Function ShellExecute Lib "shell32.dll" Alias _
  "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, _
  ByVal lpFile As String, ByVal lpParameters As String, _
  ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

Public Sub PrintSelectedAttachments()
  Dim Exp As Outlook.Explorer
  Dim Sel As Outlook.Selection
  Dim obj As Object
  Set Exp = Application.ActiveExplorer
  Set Sel = Exp.Selection
  For Each obj In Sel
    If TypeOf obj Is Outlook.MailItem Then
      PrintAttachments obj
    End If
  Next
End Sub
Private Sub PrintAttachments(oMail As Outlook.MailItem)
  Const BasePath = "Rechnungen ab 2019_06_18"
  Dim Folder As String
  Dim Path As String
  Dim colAtts As New Collection
  Dim oAtt As Outlook.Attachment
  Dim ReceivedTime As String
  Dim FileEnd As String
 
 
   
  For Each oAtt In oMail.Attachments
  FileEnd = Right$(oAtt.FileName, 4)
        If Right$(oAtt.FileName, 4) = ".pdf" Then
            colAtts.Add oAtt
    ElseIf Right$(oAtt.FileName, 4) = ".PDF" Then
            colAtts.Add oAtt
    End If
  Next
   
  If colAtts.Count Then
    'Pfad
    Folder = BasePath & Right(oMail.SenderEmailAddress, Len(oMail.SenderEmailAddress) - InStr(1, oMail.SenderEmailAddress, "@"))
    If Dir$(Folder, vbDirectory) = vbNullString Then MkDir Folder
   
    'Datum formatiert
    ReceivedTime = Format$(oMail.ReceivedTime, "yyyymmddhhnnss_")
   
    'Dateien speichern und drucken
    For Each oAtt In colAtts
      Path = Folder & ReceivedTime & oAtt.FileName
      'Speichern
      oAtt.SaveAsFile Path
      'Drucken
      ShellExecute 0, "print", Path, vbNullString, vbNullString, 0
    Next
  End If
    ' Aufruf Archivierungsmakro
  Call ArchiveItems
End Sub

Sub ArchiveItems()
    ' Verschiebt alle selektierten Mails des geöffneten Postfaches in den Ordner Rechnungsarchiv.
    Dim olApp As New Outlook.Application
    Dim olExp As Outlook.Explorer
    Dim olSel As Outlook.Selection
    Dim olNameSpace As Outlook.NameSpace
    Dim olArchive As Outlook.Folder
    Dim intItem As Integer
    Set olExp = olApp.ActiveExplorer
    Set olSel = olExp.Selection
    Set olNameSpace = olApp.GetNamespace("MAPI")
      Set olArchive = olNameSpace.Folders.Item("invoice.de@firma.com").Folders("Rechnungsarchiv")
    For intItem = 1 To olSel.Count
        olSel.Item(intItem).Move olArchive
    Next intItem
End Sub
SDAU_Jens
Neuling
 
Beiträge: 1
Registriert: 14. Jun 2019, 06:55

Zurück zu Outlook Forum (provisorisch)

Wer ist online?

Mitglieder in diesem Forum: 0 Mitglieder und 3 Gäste