Move read emails to an other folder

[oz_kar]

New to VBA, searched the internet for a script to move read email to a folder based on the senders name and found the following listed below.

I don't know VBA and the script doesn't do anything. The poster suggests that reader contact someone who knows VBA.

So, HELP! Can someone tell me why this script is not working.

Using Outlook 2010.



Sub FileMessage()
Const olFolderInbox = 6
Dim objItem As Outlook.MailItem
Dim objMailbox As Outlook.MAPIFolder
Dim FolderToSendTo As String
Set objOutlook = CreateObject("Outlook.Application")
Set objNamespace = objOutlook.GetNamespace("MAPI")
Set objInbox = objNamespace.GetDefaultFolder(olFolderInbox)
strFolderName = objInbox.Parent
Set objMailbox = objNamespace.folders(strFolderName)
Set colItems = objInbox.Items
If objOutlook.ActiveExplorer.Selection.Count = 0 Then
'Require that this procedure be called only when a message is selected
Exit Sub
End If
For Each objItem In objOutlook.ActiveExplorer.Selection
If objItem.Class = olMail Then
' SenderEmailType is "EX" or "SMTP"
' SenderEmailAddress
' SenderName
FolderToSendTo = ""
If objItem.SenderEmailType = "SMTP" Then
' Lets determine the domain name to file in under
atLoc = InStr(objItem.SenderEmailAddress, "@")
DomainName = Right(objItem.SenderEmailAddress, Len(objItem.SenderEmailAddress) - atLoc)
If LCase(DomainName) = "vmware.com" Then
DomainName = Left(objItem.SenderEmailAddress, atLoc - 1)
DomainName = Replace(DomainName, ".", " ") ' Replace dots with spaces
DomainName = Replace(DomainName, "'", "") ' Replace quotes with nothing
End If
FolderToSendTo = DomainName
ElseIf objItem.SenderEmailType = "EX" Then
'MsgBox objItem.SenderName, vbOKOnly + vbExclamation, "INFO"
FolderToSendTo = objItem.SenderName
Else
MsgBox "Don't know what to do, unknown SenderEmailType (not EX or SMTP)", vbOKOnly + vbExclamation, " OPPS"
Exit Sub
End If

' MsgBox "Will look for folder " + FolderToSendTo, vbOKOnly, "INFO"
FindFolder objMailbox, objItem, FolderToSendTo
End If
Next
Set objItem = Nothing
Set objFolder = Nothing
Set objInbox = Nothing
Set objNS = Nothing
End Sub
Sub FindFolder(oFolder As Outlook.MAPIFolder, theMessage As Outlook.MailItem, theFolderToFind)
Dim folders As Outlook.MAPIFolder
Dim iFolder As Outlook.MAPIFolder
Dim foldercount As Integer

Set theFolders = oFolder.folders
foldercount = theFolders.Count
'Check if there are any folders below oFolder
If foldercount Then
For Each iFolder In theFolders
If theFolderToFind <> "" Then
' Debug.Print iFolder.FolderPath + " ^ " + theFolderToFind
If InStr(LCase(iFolder.FolderPath), "\" + LCase(theFolderToFind)) Then
' Move it to the final location!
theMessage.UnRead = False
theMessage.Move iFolder
theFolderToFind = ""
Else
FindFolder iFolder, theMessage, theFolderToFind
End If
End If
Next
End If
End Sub