E-mails verplaatsen mbv VBA

NicoRoos · 9 jul 2020

Beste,

Ik heb een VBA code draaien voor het verplaatsen van emails naar mappen binnen outlook-bestand.
Echter krijg ik nu de volgende melding, voorheen werkte het feilloos.

De melding is "Fout 13 tijdens uitvoering: Typen komen niet met elkaar overeen"

De code die gebruik is:

Code:

Public Sub Archiveren()
    
    Dim currentExplorer As Explorer
    Dim Selection As Selection
    Dim obj As MailItem
    
    Dim myNameSpace As Outlook.NameSpace
    Dim myInbox As Outlook.Folder
    Dim Folder1 As Outlook.Folder
 
    Set currentExplorer = Application.ActiveExplorer
    Set Selection = currentExplorer.Selection
 
 
    For Each obj In Selection
  
     If obj.Categories = "SPIE" Then
        Set myNameSpace = Application.GetNamespace("MAPI")
        Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox).Folders("SPIE Nederland")
        Set Folder1 = myInbox.Folders("Ingaand")
        obj.UnRead = False
        obj.Move Folder1
    End If
  
 
      If obj.Categories = "RO" Then
        Set myNameSpace = Application.GetNamespace("MAPI")
        Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox).Folders("RO Samen sneller Op Bestemming")
        Set Folder1 = myInbox.Folders("Ingaand")
        obj.UnRead = False
        obj.Move Folder1
    End If
    
    If obj.Categories = "A15/N3 Strukton" Then
        Set myNameSpace = Application.GetNamespace("MAPI")
        Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox).Folders("A15/N3 Reconstructie Af- en toerit 23")
        Set Folder1 = myInbox.Folders("Ingaand")
        obj.UnRead = False
        obj.Move Folder1
    End If
  
    If obj.Categories = "NO-04" Then
        Set myNameSpace = Application.GetNamespace("MAPI")
        Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox).Folders("NO-04 Verplaatsen DS")
        Set Folder1 = myInbox.Folders("Ingaand")
        obj.UnRead = False
        obj.Move Folder1
    End If
    
    If obj.Categories = "NO-15" Then
        Set myNameSpace = Application.GetNamespace("MAPI")
        Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox).Folders("NO-15 VRI Horst")
        Set Folder1 = myInbox.Folders("Ingaand")
        obj.UnRead = False
        obj.Move Folder1
    End If
    
    If obj.Categories = "NO-21" Then
        Set myNameSpace = Application.GetNamespace("MAPI")
        Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox).Folders("NO-21 IM Camera's A2 en A27")
        Set Folder1 = myInbox.Folders("Ingaand")
        obj.UnRead = False
        obj.Move Folder1
    End If
    
    If obj.Categories = "NO-23" Then
        Set myNameSpace = Application.GetNamespace("MAPI")
        Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox).Folders("NO-23 VRI Leenderheide")
        Set Folder1 = myInbox.Folders("Ingaand")
        obj.UnRead = False
        obj.Move Folder1
    End If
    
     If obj.Categories = "NO-25" Then
        Set myNameSpace = Application.GetNamespace("MAPI")
        Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox).Folders("NO-25 VKS KP Ekkersrijt en Rotatiepaneel KP Vonderen")
        Set Folder1 = myInbox.Folders("Ingaand")
        obj.UnRead = False
        obj.Move Folder1
    End If
    
    If obj.Categories = "NO-26" Then
        Set myNameSpace = Application.GetNamespace("MAPI")
        Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox).Folders("NO-26 LED verlichting ZN")
        Set Folder1 = myInbox.Folders("Ingaand")
        obj.UnRead = False
        obj.Move Folder1
    End If
    
    If obj.Categories = "NO-28" Then
        Set myNameSpace = Application.GetNamespace("MAPI")
        Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox).Folders("NO-28 Filebeveiligingssysteem A58")
        Set Folder1 = myInbox.Folders("Ingaand")
        obj.UnRead = False
        obj.Move Folder1
    End If
   
    If obj.Categories = "NO-V02" Then
        Set myNameSpace = Application.GetNamespace("MAPI")
        Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox).Folders("NO-V02 Led A12")
        Set Folder1 = myInbox.Folders("Ingaand")
        obj.UnRead = False
        obj.Move Folder1
    End If

    Next
    
    Set currentExplorer = Nothing
    Set obj = Nothing
    Set Selection = Nothing
    Set Folder1 = Nothing

 
End Sub

Weet iemand wat er aan de hand is?

edmoor · 9 jul 2020

En op welke regel krijg je die melding?

En niet dat het wat met je probleem te maken heeft, maar volgens mij kan het ook een stuk korter:

Code:

Public Sub Archiveren()
    Dim currentExplorer As Explorer
    Dim Selection As Selection
    Dim obj As MailItem
    
    Dim myNameSpace As Outlook.Namespace
    Dim myInbox As Outlook.Folder
    Dim Folder1 As Outlook.Folder
    Dim FromFolder As String
    
    Set currentExplorer = Application.ActiveExplorer
    Set Selection = currentExplorer.Selection
 
    For Each obj In Selection
        Select Case obj.Categories
            Case "SPIE":    FromFolder = "SPIE Nederland"
            Case "RO":      FromFolder = "RO Samen sneller Op Bestemming"
            Case "A15/N3":  FromFolder = "A15/N3 Reconstructie Af- en toerit 23"
            Case "NO-04":   FromFolder = "NO-04 Verplaatsen DS"
            Case "NO-15":   FromFolder = "NO-15 VRI Horst"
            Case "NO-21":   FromFolder = "NO-21 IM Camera's A2 en A27"
            Case "NO-23":   FromFolder = "NO-23 VRI Leenderheide"
            Case "NO-25":   FromFolder = "NO-25 VKS KP Ekkersrijt en Rotatiepaneel KP Vonderen"
            Case "NO-26":   FromFolder = "NO-26 LED verlichting ZN"
            Case "NO-28":   FromFolder = "NO-28 Filebeveiligingssysteem A58"
            Case "NO-V02":  FromFolder = "NO-V02 Led A12"
        End Select
  
        Set myNameSpace = Application.GetNamespace("MAPI")
        Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox).Folders(FromFolder)
        Set Folder1 = myInbox.Folders("Ingaand")
        obj.UnRead = False
        obj.Move Folder1
    Next
    
    Set currentExplorer = Nothing
    Set obj = Nothing
    Set Selection = Nothing
    Set Folder1 = Nothing
End Sub

NicoRoos · 9 jul 2020

Oke, dat ziet er een stuk overzichterlijker uit.
Ik ga deze sowieso erin zetten, alvast bedankt hiervoor.

Ik krijg de melding op regel: Set myNameSpace = Application.GetNamespace("MAPI")

Bij elke catergorie.

Edit:

Als ik de verkorte code toepast werkt het wel.

alphamax · 9 jul 2020

Als je de mogelijkheden van catogories goed gebruikt, heb je geen vba nodig, zie https://www.techrepublic.com/blog/10-things/10-ways-to-get-the-most-out-of-outlook-categories/

alphamax · 9 jul 2020

Misschien staat hier de oplossing, zie https://answers.microsoft.com/en-us...error-on/d1d8d61a-768e-4a4d-939b-b161ad0c71f9
Bron: google "application.getnamespace( mapi ) outlook error 13"

E-mails verplaatsen mbv VBA

NicoRoos

Nieuwe gebruiker

edmoor

Inventaris

NicoRoos

Nieuwe gebruiker

alphamax

Terugkerende gebruiker

alphamax

Terugkerende gebruiker

Nieuwste berichten

Wij waarderen jouw privacy