Outlook Macro - Print, opslaan en verplaats bijlage

[Nico84]

Alle mails komen binnen in Postvak IN.
Hierin wil ik 1 of meerdere mails selecteren en vervolgens door een knop
in de werkbalk meerdere acties laten uitvoeren.

-Print de bijlage van de geselecteerde mails
-Opslaan van de bijlage in een map. (met de datum en tijd van wanneer het ontvangen is.
-Verplaatsen van de mail naar de map administratie.
Onderstaande code heb ik gevonden voor het verplaatsen van de mail en dit werkt goed.

Kan iemand mij op weg helpen voor het printen en opslaan en hoe ik het verwerkt in onderstaande code.

Sub Verplaatsen()
'opbouw van de mappenstruktuur :
'\\Persoonlijke mappen\Postvak IN\Administratie

On Error Resume Next
Dim objFolder As Outlook.MAPIFolder, objInbox As Outlook.MAPIFolder
Dim objNS As Outlook.NameSpace, objItem As Outlook.MailItem
Set objNS = Application.GetNamespace("MAPI")
Set objInbox = objNS.GetDefaultFolder(olFolderInbox)
Set objBewaarFolder = objInbox.Folders("Administratie")

'indien de folder "Administratie" niet aanwezig is de macro stoppen
If objBewaarFolder Is Nothing Then
    Exit Sub
End If

'Require that this procedure be called only when a message is selected
If Application.ActiveExplorer.Selection.Count = 0 Then
    MsgBox "Er is geen e-mail bericht geselecteerd.", vbOKOnly + vbExclamation, "Foutmelding"
    Exit Sub
End If

For Each objItem In Application.ActiveExplorer.Selection
    If objFolder.DefaultItemType = olMailItem Then
        If objItem.Class = olMail Then
            objItem.UnRead = False
            objItem.Move objBewaarFolder
        End If
    End If
Next

Set objItem = Nothing
Set objBewaarFolder = Nothing
Set objInbox = Nothing
Set objNS = Nothing


End Sub

 

[gast0660]

Hoi,
Probeer deze eens:

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

Private WithEvents Items As Outlook.Items

Private Sub Application_Startup()
  Dim Ns As Outlook.NameSpace
  Dim Folder As Outlook.MAPIFolder

  Set Ns = Application.GetNamespace("MAPI")
  Set Folder = Ns.GetDefaultFolder(olFolderInbox)
  Set Items = Folder.Items
End Sub

Private Sub Items_ItemAdd(ByVal Item As Object)
  If TypeOf Item Is Outlook.MailItem Then
    PrintAttachments Item
  End If
End Sub

Private Sub PrintAttachments(oMail As Outlook.MailItem)
  On Error Resume Next
  Dim colAtts As Outlook.Attachments
  Dim oAtt As Outlook.Attachment
  Dim sFile As String
  Dim sDirectory As String
  Dim sFileType As String

  sDirectory = [COLOR="#FF0000"]"D:Attachments"[/COLOR][COLOR="#008000"]' Map waar de bijlage wordt opgeslagen[/COLOR]

  Set colAtts = oMail.Attachments

  If colAtts.Count Then
    For Each oAtt In colAtts

      sFileType = LCase$(right$(oAtt.FileName, 4))

      Select Case sFileType
      Case [COLOR="#FF0000"]".xls", ".doc"[/COLOR][COLOR="#008000"]' soort documenten, bijvoegen naar keuze,"xlsx", "docx", ".pdf" [/COLOR]
        sFile = ATTACHMENT_DIRECTORY & oAtt.FileName
        oAtt.SaveAsFile sFile
        ShellExecute 0, "print", sFile, vbNullString, vbNullString, 0
      End Select
    Next
  End If
End Sub