Outlook 2010 Makro zum Drucken, speichern und verschieben

Schönen guten Tag,

ich möchte von einer eMail nur den PDF-Anhang auf einen bestimmten Drucker (doppelseitig) ausgeben, die PDF auf einen Netzwerkordner speichern und danach die markierte Mail in das Archiv oder ein anderes Mailkonto verschieben. Das ganze per VBA und Knopf auf dem Menüband.

Den Teil mit dem speichern auf dem Netzwerkordner habe ich lösen können.
Könnte noch etwas verfeinert werden, indem nur PDFs beachtet werden. Aber das, ebenso der automatische Druck, ist zweitrangig.

Sub Anlagen()
    Dim att As Attachment, strPath As String, olMail As MailItem
    strPath = "Z:\MITARBEITER\eMail-Rg-Archiv"  
    For Each olMail In ActiveExplorer.Selection
        If olMail.Attachments.count > 0 Then
            For Each att In olMail.Attachments
                att.SaveAsFile strPath & "\" & Format(olMail.ReceivedTime, "yyyymmdd_hhnnss ") & "(" & olMail.SenderName & ")" & " - " & att.FileName  
            Next
        End If
    Next
End Sub

Hier wäre der Teil, der die Mail danach verschieben soll. Ursprünglich ist der Code für einen ganzen Ordner gedacht und ich habe damit ein wenig experimentiert. Es wird nicht die markierte Mail verschoben, sondern irgendeine andere. Hier könnte ich etwas Hilfe gebrauchen.

Sub Test()
   Dim oOutlook As Object
   Dim oNSpace As Object
   Dim oFolderA As Object
   Dim oFolderB As Object
   Dim oMsg As Object
   Dim iCounter As Integer, iCount As Integer
   Set oOutlook = CreateObject("Outlook.Application")  
   Set oNSpace = oOutlook.GetNamespace("MAPI")  
   Set oFolderA = oNSpace.Folders("info@firma.de") _  
      .Folders("Test")  
   Set oFolderB = oNSpace.Folders("rechnung@firma.de") _  
      .Folders("Test1")  
   'iCount = oFolderA.Items.count  
   'If iCount > 0 Then  
   '   For iCounter = 1 To iCount  
         Set oMsg = oFolderA.Items(1)
         oMsg.Move oFolderB
   '   Next iCounter  
   'End If  
   Set oNSpace = Nothing
   Set oFolderA = Nothing
   Set oFolderB = Nothing
   Set oMsg = Nothing
   Set oOutlook = Nothing
End Sub

Eine Alternative per Add-On wäre auch interessant. Wenn bekannt.

Viele Grüße
André

Bitte markiere auch die Kommentare, die zur Lösung des Beitrags beigetragen haben

Content-ID: 277379

Url: https://administrator.de/contentid/277379

Ausgedruckt am: 19.11.2024 um 13:11 Uhr

3 Kommentare

Neuester Kommentar

Sub Anlagen()
    Dim att As Attachment, strPath As String, olMail As MailItem, col As New Collection
    strPath = "Z:\MITARBEITER\eMail-Rg-Archiv"  
    For Each olMail In ActiveExplorer.Selection
        If olMail.Attachments.count > 0 Then
            For Each att In olMail.Attachments
            	If LCase(Right(att.Filename,3)) = "pdf" Then  
                	att.SaveAsFile strPath & "\" & Format(olMail.ReceivedTime, "yyyymmdd_hhnnss ") & "(" & olMail.SenderName & ")" & " - " & att.FileName  
                End If
            Next
        End If
        col.Add olMail
    Next
    Set folderTarget = Application.Session.Stores.Item("NAME DES STORES").GetRootFolder.Folders.Item("rechnung@firma.de")  
    For Each m In col
    	m.Move folderTarget
    Next
End Sub

Zum Drucken schaue hier:
Print Outlook Attachment - AdobeReader ist zu langsam für Makro!

Gruß grexit

Hallo grexit,

vielen Dank dafür!
Beim Verschieben gab es noch Probleme. Ich habe den Code Zeile 14 etwas angepasst.

Sub Anlagen()
    Dim att As Attachment, strPath As String, olMail As MailItem, col As New Collection
    strPath = "Z:\MITARBEITER\eMail-Rg-Archiv"  
    For Each olMail In ActiveExplorer.Selection
        If olMail.Attachments.count > 0 Then
            For Each att In olMail.Attachments
                If LCase(Right(att.FileName, 3)) = "pdf" Then  
                    att.SaveAsFile strPath & "\" & Format(olMail.ReceivedTime, "yyyymmdd_hhnnss ") & "(" & olMail.SenderName & ")" & " - " & att.FileName  
                End If
            Next
        End If
        col.Add olMail
    Next
    Set folderTarget = Application.Session.Stores.Item("rechnung@firma.de").GetRootFolder.Folders("Archiv")  
    For Each m In col
        m.Move folderTarget
    Next
End Sub