VBA - Nørd ? - Hjælp Outlook Macro

Option Explicit


Private WithEvents Items As Outlook.Items
Private Sub Application_Startup()
  Dim olApp As Outlook.Application
  Dim objNS As Outlook.NameSpace
  Set olApp = Outlook.Application
  Set objNS = olApp.GetNamespace("MAPI")
  ' default local Inbox
  Set Items = objNS.GetDefaultFolder(olFolderInbox).Items
End Sub
Private Sub Items_ItemAdd(ByVal Item As Object)
 
  Dim arTemp() As String
  Dim sDomain  As String

  On Error GoTo ErrorHandler
  Dim Msg As Outlook.MailItem
  If TypeName(Item) = "MailItem" Then
    Set Msg = Item
    ' ******************
    ' do something here
    ' ******************
   
   
   
         
    arTemp = Split(Item.SenderEmailAddress, "@")
    sDomain = "@" & arTemp(UBound(arTemp))
    sDomain = LCase(sDomain)
   
    'MsgBox sDomain
   
    CreateFolders (sDomain)
 
  End If
ProgramExit:
  Exit Sub
ErrorHandler:
  MsgBox Err.Number & " - " & Err.Description
  Resume ProgramExit
End Sub


Function CreateFolders(maildomain As String)

  Dim CurrentFolder As Outlook.MAPIFolder
  Dim SubFolder As Outlook.MAPIFolder
  Dim List As New VBA.Collection
  Dim Folders As Outlook.Folders
  Dim Item As Variant

  Dim ns As Outlook.NameSpace
  Dim PstFolder As Outlook.MAPIFolder
 
  Dim objSourceFolder As Outlook.MAPIFolder
  Dim objDestFolder As Outlook.MAPIFolder
  Dim objItem As Outlook.MailItem
  Dim objCopy As Outlook.MailItem

  Set ns = Application.GetNamespace("MAPI")

  'PST fil,RootFolder,SubFolder,MailDomain
 
  Select Case Trim(maildomain)
    Case "@maildomain.dk"
        List.Add Array("PstFil-Arkiv", "00-Folder 1", "SubFolder Test 1")
    Case "@mvb.net"
        List.Add Array("PstFil-Arkiv", "00-Folder 2", "SubFolder Test 2")
    Case Else
        MsgBox "Ingen Regel oprettet for MailDomain " & maildomain
  End Select


  'Opret Folder i PstFil-Arkiv

 
   
  'MsgBox maildomain

  For Each Item In List
    'Define path to the target folder
   
    Set PstFolder = ns.Folders(Trim(Item(0)))              'Vælger PST-Fil
        On Error Resume Next
        PstFolder.Folders.Add Trim(Item(1)), olFolderInbox  'Opretter RootFolder
   
    Set SubFolder = ns.Folders(Trim(Item(0))).Folders(Trim(Item(1)))
        On Error Resume Next
        SubFolder.Folders.Add Trim(Item(2)), olFolderInbox
       
 
   
    'MsgBox Item(0)
   
 
    Set objDestFolder = ns.Folders(Trim(Item(0))).Folders(Trim(Item(1))).Folders(Trim(Item(2)))
 
    Set objItem = Application.ActiveExplorer.Selection.Item(1)
       
    ' copy and move first
   
    Set objCopy = objItem.Copy
      objCopy.Move objDestFolder
     
    ' then do whatever
     
        With objItem
            .UnRead = False
            .MarkAsTask olMarkComplete
            .Categories = "Kopi af Mail gemt i folder"
            .Save
        End With
   
  Next
   
     
  Set CurrentFolder = Nothing
  Set SubFolder = Nothing
  Set List = Nothing
  Set Folders = Nothing
  Set Item = Nothing

  Set ns = Nothing
  Set PstFolder = Nothing
 
  Set objSourceFolder = Nothing
  Set objDestFolder = Nothing
  Set objItem = Nothing
  Set objCopy = Nothing
   
 
End Function

Jeg har ovenfor kode i VBA til brug i Outlook 2016
Det jeg vil med koden er:
Når jeg modtager en mail i min Indbakke skal den
gå ned i min Arkiv mappe og oprette en Folder og derefter skal
den lave en kopi af den indkommende mail og flytte til Arkiv mappen
Altså både en mail i indbakken og kopi af den samme i Arkiv folder.
Reglen for mappens navn op placering - er basset på det indkommede maildomain - det har jeg fået til at virke.
Men der mangler noget i koden til at automatisk at vælge den indkommende
mail for at kunne lave en kopi og flytte den ned i Arkiv mappen ?
Der mangler også noget hvis der feks kommer 5 på hinnanden følgende mail
i indbakke - til at sørge for at alle 5 bliver behandlet ?