Sort emails into folders by sender's name

[anariet]

Cheers all!

I'm new to VBA and I need some help. I'm trying to write a script to automatically sort all emails on my inbox into PST subfolders named by sender's name.

ie:

Sender 1 should go to "Sender 1" subfolder
Sender 2 should go to "Sender 2" subfolder

The catch is: I don't want to create any new subfolders. All emails which doesn't have according subfolders should be ignored and left on the inbox.

ie:

if there isn't already a "Sender 3" subfolder, all emails sent by Sender 3 should be left on the inbox

The code is working for existing subfolders, but when it doesn't find a subfolder, it halts and stops processing the rest of them items.

Can anyone help me out?

Thanks!


Sub MoverEmails()
Dim olns As Outlook.NameSpace
Dim oConItems As Outlook.Items
Dim iNumItems As Integer
Dim objTargetFolder As Outlook.MAPIFolder

Set objNS = Application.GetNamespace("MAPI")
Set oInboxItems = objNS.GetDefaultFolder(olFolderInbox).Items

iNumItems = oInboxItems.Count

For I = iNumItems To 1 Step -1
Set objCurItem = oInboxItems.Item(I)
If TypeName(objCurItem) = "MailItem" Then
objDestFolder = objCurItem.SenderName
Set objTargetFolder = Outlook.Application.GetNamespace("MAPI").Folders("PST Trabalho").Folders("Meus Emails").Folders("Teste").Folders(objDestFolder)
objCurItem.Move objTargetFolder
End If
Next

MsgBox "Movidos " & iNumItems & " items."

Set objInboxItems = Nothing
Set objTargetFolder = Nothing
Set objNS = Nothing

End Sub

[Charlize]

Not tested, beware ...
For I = iNumItems To 1 Step -1
Set objCurItem = oInboxItems.Item(I)
If TypeName(objCurItem) = "MailItem" Then
objDestFolder = objCurItem.SenderName
'when there's an error, don't bother and go on
On Error Resume Next
Set objTargetFolder = Outlook.Application.GetNamespace("MAPI").Folders("PST Trabalho").Folders("Meus Emails").Folders("Teste").Folders(objDestFolder)
'reset the errortrapping to hold on all errors
On Error GoTo 0
'Here we check if the name of the folder (i hope you declared this one as a folder)
'isn't empty and then we move it
If objTargetFolder.Name <> vbNullString Then
objCurItem.Move objTargetFolder
'do you have to save the move ?
End If
End If
Next ICharlize

[anariet]

Charlize,

Thanks a lot for your response!

I get an error 91 from your code ("Object variable or with block variable not set").

About your comment hoping I declared "objTargetFolder" as a folder, you meant "Dim objTargetFolder As Outlook.MAPIFolder", right? Or is there something else I should be doing?

Here's the full code again, with your inputs. I can't see which variable I'm not declaring. :(

Thanks a lot!



Sub MoverEmails()
Dim olns As Outlook.NameSpace
Dim oConItems As Outlook.Items
Dim iNumItems As Integer
Dim objTargetFolder As Outlook.MAPIFolder

Set objNS = Application.GetNamespace("MAPI")
Set oInboxItems = objNS.GetDefaultFolder(olFolderInbox).Items

iNumItems = oInboxItems.Count

For I = iNumItems To 1 Step -1
Set objCurItem = oInboxItems.Item(I)
If TypeName(objCurItem) = "MailItem" Then
objDestFolder = objCurItem.SenderName
'when there's an error, don't bother and go on
On Error Resume Next
Set objTargetFolder = Outlook.Application.GetNamespace("MAPI").Folders("PST Trabalho").Folders("Meus Emails").Folders("Teste").Folders(objDestFolder)
'reset the errortrapping to hold on all errors
On Error GoTo 0
'Here we check if the name of the folder (i hope you declared this one as a folder)
'isn't empty and then we move it
If objTargetFolder.name <> vbNullString Then
objCurItem.Move objTargetFolder
'do you have to save the move ?
End If
End If
Next I

MsgBox "Movidos " & iNumItems & " items."

Set objInboxItems = Nothing
Set objTargetFolder = Nothing
Set objNS = Nothing

End Sub

[anariet]

Hey there! I finally got it working! :thumb

Here's the final code.

Thanks for your help!



Sub MoverEmails()
Dim olns As Outlook.NameSpace
Dim oConItems As Outlook.Items
Dim iNumItems As Integer
Dim objTargetFolder As Outlook.MAPIFolder
Dim Cont As Integer

On Error Resume Next

Cont = 0


Set objNS = Application.GetNamespace("MAPI")
Set oInboxItems = objNS.GetDefaultFolder(olFolderInbox).Items

iNumItems = oInboxItems.Count

For I = iNumItems To 1 Step -1
Set objCurItem = oInboxItems.Item(I)
If TypeName(objCurItem) = "MailItem" Then
objDestFolder = objCurItem.SenderName
Set objTargetFolder = Outlook.Application.GetNamespace("MAPI").Folders("PST Trabalho").Folders("Meus Emails").Folders("Pessoas").Folders(objDestFolder)
On Error Resume Next
If Not objTargetFolder Is Nothing Then
objCurItem.Move objTargetFolder
Cont = Cont + 1
Set objTargetFolder = Nothing
End If
End If
Next

MsgBox "Emails movidos: " & Cont

Set objInboxItems = Nothing
Set objTargetFolder = Nothing
Set objNS = Nothing

End Sub

[Charlize]

Not sure but I would reactivate the error trapping after you set it off
If TypeName(objCurItem) = "MailItem" Then
objDestFolder = objCurItem.SenderName
'I would set it here
On Error Resume Next
Set objTargetFolder = Outlook.Application.GetNamespace("MAPI").Folders("PST Trabalho").Folders("Meus Emails").Folders("Pessoas").Folders(objDestFolder)
'Here you reset the error trapping
On Error GoTo 0
If Not objTargetFolder Is Nothing Then
objCurItem.Move objTargetFolder
Cont = Cont + 1
Set objTargetFolder = Nothing
End If
End Ifthe = nothing thing would be my next best guess :think: (try-out). But you thought of it yourself :thumb .

Charlize

ps.: Sorry, I overlooked the declaring of that folder. Don't take notice of that question.