How can I create a script to move the currently active email in the Inbox to another folder in Outlook 2007 - vba

I sometimes get emails that I want to keep but to move them into the appropriate folder can be a pain. How can I execute a script that will move (like using C-S-v) the email I'm looking at into a certain folder called "buffer", for instance?
I'm using Outlook 2007.
thanks.
EDIT:
there isn't any criteria that can be created to automate this process like through a rule. it is merely a judgment call I make as i'm staring at it.

This code may work better.
In your code, objFolder may be equal to Nothing, yet you continue the procedure. Also, the For Each loop assumes that each item is a mail item.
Sub MoveSelectedMessagesToFolder()
Dim objNS As Outlook.NameSpace
Dim objFolder As Outlook.MAPIFolder
Dim obj As Object
Dim msg As Outlook.mailItem
Set objNS = Application.GetNamespace("MAPI")
On Error Resume Next
Set objFolder = objNS.Folders.item("Personal Folders").Folders.item("Buffer")
On Error GoTo 0
If objFolder Is Nothing Then
MsgBox "This folder doesn't exist!", vbOKOnly + vbExclamation, "INVALID FOLDER"
Exit Sub
End If
For Each obj In ActiveExplorer.Selection
If TypeName(obj) = "MailItem" Then
Set msg = obj
msg.Move objFolder
End If
Next obj
End Sub

Here's the code I'm using.
Sub MoveSelectedMessagesToFolder()
'Originally written by Chewy Chong
'Taken from http://verychewy.com/archive/2006/04/12/outlook-macro-to-move-an-email-to-folder.aspx
'Thanks Chewy!
'Ken
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)
'For the "Item" portion, I used the name of the folder exactly as it appear in the ToolTip when I hover over it.
Set objFolder = objNS.Folders.Item("Personal Folders").Folders.Item("Buffer")
'Assume this is a mail folder
If objFolder Is Nothing Then
MsgBox "This folder doesn't exist!", vbOKOnly + vbExclamation, "INVALID FOLDER"
End If
If Application.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 Application.ActiveExplorer.Selection
If objFolder.DefaultItemType = olMailItem Then
If objItem.Class = olMail Then
objItem.Move objFolder
End If
End If
Next

Tools -> Rules & Alerts
Then Create a new rule telling all mail that fit whatever criteria to be deleted/marked as read/moved to a folder/any combination of those.
Edit:
If you don't want a rule/can't make a rule that fits, you can create a Macro (Tools -> Macro) to move it to a folder, then bind it to a shortcut.

Related

Outlook vba does not find existing folder

My Outlook macro worked at one time, then stopped. When it parses, the macro throws an error "Compile Error: Variable not defined". It seems the macro does not recognize that that folder exists. I cut the code to the bare minimum and it is a repeatable problem. The macro will recognize standard folders such as JUNK and DRAFTS but not PROCESSED_FOLDERS. I have tried renaming Processed_Folders as well as creating a new folder with a different name. No joy.
Folder structure is:
reports#xxx.com
Inbox
Drafts
Sent
Trash
Junk
Processed_Reports
Outbox
Sync Issues1 (This computer only)
SearchFolders
CODE:
Sub testfforfolder()
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim olFolder As Outlook.MAPIFolder
Dim msg As Outlook.MailItem
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
Set olFolder = objNS.GetDefaultFolder(olFolderInbox)
On Error GoTo xyz
Set olFolder = olFolder.Folders("Processed_Reports")
MsgBox "Folder Exists" ' This line works if I use DRAFTS or JUNK
Exit Sub
xyz:
MsgBox ("Cannot find Folder") ' I get here if I use PROCESSED_REPORTS
Exit Sub
End Sub
Thanks to the comment by Tony Dallimore I was able to solve the issue. The link to https://stackoverflow.com/a/12146315/973283 let me solve the problem. With an updated version of Outlook, the default email account was being referenced rather than the account of the selected item. The Processed_Reports folder only existed in a different account folder. The solution, as Tony suggested, was to set the target folder to the full path to the target. I did need one more level as shown in the working solution below.
Sub testfforfolder()
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim olFolder As Outlook.MAPIFolder
Dim msg As Outlook.MailItem
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
Set olFolder = objNS.GetDefaultFolder(olFolderInbox)
On Error GoTo xyz
'OLD INCORRECT
'Set olFolder = olFolder.Folders("Processed_Reports")
'WORKING CORRECTION
Set TgtFolder= _
Session.Folders("reports#xxx.com"). _
Folders("Inbox").Folders("Processed_Reports")
MsgBox "Folder Exists" ' This line works if I use DRAFTS or JUNK
Exit Sub
xyz:
MsgBox ("Cannot find Folder") ' I get here if I use PROCESSED_REPORTS
Exit Sub
End Sub
here is a way to get the session folder without knowing the session name
Sub topFolder()
Dim topFolder As Folder
Set topFolder = Application.Session.GetDefaultFolder(olFolderInbox).Parent
Dim i As Integer
For i = 1 To topFolder.Folders.Count
Debug.Print topFolder.Folders(i).Name
Next i
For i = 1 To topFolder.Folders("inbox").Folders.Count
Debug.Print topFolder.Folders("inbox").Folders(i).Name
Next i
End Sub

Need Error Message: Move To code

I have a Move to Code. The issue I am having is a result of multiple accounts. I have 3 to be exact.
Let's say - My boss emailed me, so I jump from my work account to my personal account. I read her email, jump back to my work account and run macro. It moves her (last read/selected) to location. I don't know how many personal emails I've moved by mistake because I forgot to reselect the correct email I meant to move.
How can I produce a prompt message stating I'm in the wrong account and if I should proceed? Note: there may be times I may need to proceed.
Additional Information:
Account One: Chieri Thompson (Personal)
Account Two: Artwork Emails
Account Three: DesignProofsTAC (work email - the one utilizing move to macro)
Under Design Proofs TAC is :
Inbox (folder)
Completed (subfolder)
Outsourced (subfolder)
.....
Private Sub CommandButton7_Click() 'COMPLETED
On Error Resume Next
Dim ns As Outlook.NameSpace
Dim MoveToFolder As Outlook.MAPIFolder
Dim objItem As Outlook.MailItem
Set objItem = objApp.ActiveInspector.CurrentItem
Set ns = Application.GetNamespace("MAPI")
Set MoveToFolder = ns.Folders("designproofstac").Folders("Inbox").Folders("3_COMPLETED")
If Application.ActiveExplorer.Selection.Count = 0 Then
MsgBox ("Not in Correct Folder")
Exit Sub
End If
' this is the error code I want to produce the "you are in wrong account - proceed anyway?" DesignProofsTAC should be "default" i guess.
If MoveToFolder Is Nothing Then
MsgBox "Target folder not found!", vbOKOnly + vbExclamation, "Move Macro Error"
End If
For Each objItem In Application.ActiveExplorer.Selection
If MoveToFolder.DefaultItemType = olMailItem Then
If objItem.Class = olMail Then
objItem.Move MoveToFolder
End If
End If
Next
Set objItem = Nothing
Set MoveToFolder = Nothing
Set ns = Nothing
End Sub
You may find this simpler than checking accounts.
Untested Code:
Option Explicit
Sub MoveOpenMail 'COMPLETED
' Place a button on the Quick Access Toolbar for an item opened for reading.
Dim ns As NameSpace
Dim MoveToFolder As Folder
Dim objItem As object ' <--- May not be a mailitem
Set ns = Application.GetNamespace("MAPI")
' Do not use On Error Resume Next
' unless there is a specific purpose
' and it is quickly followed by On Error GoTo 0
On Error Resume Next
Set MoveToFolder = ns.Folders("designproofstac").Folders("Inbox").Folders("3_COMPLETED")
On Error GoTo 0
If MoveToFolder Is Nothing Then
MsgBox "Target folder not found!", vbOKOnly + vbExclamation, "MoveOpenMail VBA Error"
GoTo ExitRoutine
End If
On Error Resume Next
Set objItem = ActiveInspector.CurrentItem
On Error GoTo 0
If objItem Is Nothing Then
MsgBox "Use this code when there is an open mailitem!", vbOKOnly + vbExclamation, "MoveOpenMail VBA Error"
GoTo ExitRoutine
End If
If MoveToFolder.DefaultItemType = olMailItem Then
If objItem.Class = olMail Then
objItem.Move MoveToFolder
End If
Else
MsgBox "Target folder is wrong type!", vbOKOnly + vbExclamation, "MoveOpenMail VBA Error"
End If
ExitRoutine:
Set ns = Nothing
Set MoveToFolder = Nothing
Set objItem = Nothing
End Sub
Sub MoveSelectedMail 'COMPLETED
' Place a button on the Quick Access Toolbar for an open folder
Dim ns As NameSpace
Dim MoveToFolder As Folder
Dim objItem as Object
Dim objExplorer As Explorer
Dim objSelection As Object
Dim x as Long
Set ns = Application.GetNamespace("MAPI")
On Error Resume Next
Set MoveToFolder = ns.Folders("designproofstac").Folders("Inbox").Folders("3_COMPLETED")
On Error GoTo 0
If MoveToFolder Is Nothing Then
MsgBox "Target folder not found!", vbOKOnly + vbExclamation, "MoveSelectedMail VBA Error"
GoTo ExitRoutine
End If
Set objExplorer = ActiveExplorer
Set objSelection = objExplorer.Selection
If objSelection.Count = 0 Then
MsgBox "Select one or more mailitems"
GoTo ExitRoutine
Else
If MoveToFolder.DefaultItemType = olMailItem Then
' Do not use For Each
' Count backwards when moving or deleting
For x = objSelection.Count to 1 step -1
Set objItem = objSelection.Item(x)
If objItem.Class = olMail Then
objItem.Move MoveToFolder
End If
Next x
Else
MsgBox "Target folder is wrong type!", vbOKOnly + vbExclamation, "MoveSelectedMail VBA Error"
End If
End If
ExitRoutine:
Set ns = Nothing
Set MoveToFolder = Nothing
Set objItem = Nothing
Set objExplorer = Nothing
Set objSelection = Nothing
End Sub
The Namespace class provides the Accounts property which eturns an Accounts collection object that represents all the Account objects in the current profile. The Account class provides the DeliveryStore property which returns a Store object that represents the default delivery store for the account. So, you can compare the Store where you chose the item and the default store for the account you need to move the item.
Also you may find the GetDefaultFolder method of the Store class helpful, it returns a Folder object that represents the default folder in the store and that is of the type specified by the FolderType argument. This method is similar to the GetDefaultFolder method of the NameSpace object. The difference is that this method gets the default folder on the delivery store that is associated with the account, whereas NameSpace.GetDefaultFolder returns the default folder on the default store for the current profile.

How to open the folder of current open item and select that item?

I have a Sub that opens the Folder for the current open mail-item.
This makes sense if I have an item open, but have changed the mail-Folder inbetween, and want to open the right Folder straight away again.
Sub ordner_mail_oeffnen()
On Error GoTo exit_sub
'Dim olApp As Outlook.Application
Dim olitem As Outlook.mailitem
'Set olApp = Outlook.Application
Set olitem = Outlook.Application.ActiveInspector.CurrentItem
Dim olfolder As MAPIFolder
Dim FolderPath As String
Dim Subfolder As Outlook.MAPIFolder
FolderPath = GetPath(olitem)
Set olfolder = GetFolder(FolderPath)
olfolder.Display
'those two lines are just for test purpose
MsgBox "jetzt"
Application.ActiveExplorer.ClearSelection
Sleep (10000)
Application.ActiveExplorer.ClearSelection
'here comes the runtime-error (I try to translate) "-2147467259 (80004005) element can not be activated or deactivated, as id does not exist in the current view"
Application.ActiveExplorer.AddToSelection olitem
exit_sub:
exit_sub:
End Sub
Only after the error the new Folder is opened but does not select certain mail.
Use Explorer.ClearSelection and Explorer.AddToSelection to select an item.
The current Explorer is returned from Application.ActiveExplorer.
You could continue to use GetPath(olitem) and GetFolder(FolderPath) but since the code was not included I cannot be sure.
Replace olfolder.Display with Set ActiveExplorer = olfolder.
Without GetPath(olitem) and GetFolder(FolderPath).
Option Explicit
Sub ordner_mail_oeffnen()
Dim olitem As Object
Dim olfolder As Folder
Set olitem = ActiveInspector.CurrentItem
Set olfolder = olitem.Parent
Set ActiveExplorer = olfolder
ActiveExplorer.ClearSelection
ActiveExplorer.AddToSelection olitem
End Sub
I had the same issue and found out that Outlook must be given time to bring up the new Display. This can be done using DoEvents. For me, the following works:
Option Explicit
Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal Milliseconds As LongPtr)
Sub ordner_mail_oeffnen()
Dim olitem As Outlook.MailItem
Set olitem = Outlook.Application.ActiveInspector.CurrentItem
Dim olfolder As MAPIFolder
Set olfolder = olitem.Parent
olfolder.Display
'Sleep 10000 ' does not help
'MsgBox ("Interruption") ' does not help
DoEvents ' Important!
If Application.ActiveExplorer.IsItemSelectableInView(olitem) = False Then
Stop ' We should not get here!
' But we will, if the line <DoEvents> is missing.
End If
Application.ActiveExplorer.ClearSelection
Application.ActiveExplorer.AddToSelection olitem
End Sub
If you omit the DoEvents, the code will run into the Stop command. A previous Sleep or MsgBox will not help.
Caveat: when you debug the code step by step (F8), the initial problem will not show up.

Outlook rule not running VBA code

I have VBA code to look for attachments in e-mails in a specific Outlook folder and save them into a location.
I have an Outlook rule that sends the emails to the Outlook folder then fires the macro. The code does not fire on my computer automatically, but it does on another computer. The email comes in and the rule drops it into the folder, but the code does not run. When I run the code manually, through the VB Editor, it saves the attachment in the right place.
I have checked to make sure folder and path names are correct (either way if they were wrong the code would not run properly when I run it manually).
Outlook rule:
Apply this rule after the message arrives
from xxxxxxxxxxxx
and with xxxx in the subject
and on this machine only
move it to the xxxxx folder
and run Project1.ThisOutlookSession.Save
VBA code:
Sub Save(item As Outlook.MailItem)
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim olFolder As Outlook.MAPIFolder
Dim msg As Outlook.MailItem
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
Set olFolder = objNS.GetDefaultFolder(olFolderInbox)
Set olFolder = olFolder.Folders("xxxxxxx")
Set oApp = CreateObject("Shell.Application")
For Each myitem In olFolder.Items
For Each att In myitem.Attachments
att.SaveAsFile "\\.............\" & att.FileName
myitem.Attachments.Remove 1
myitem.Save
Next
Next
End Sub
The incoming mailitem is item in Sub Save(item As Outlook.MailItem). It is not used in the code.
Later when run manually the code still ignores whatever item is passed but all items in olFolder are now processed.
Try this:
Sub Save(item As Outlook.MailItem)
For Each att In item.Attachments
att.SaveAsFile "\\.............\" & att.FileName
item.Attachments.Remove 1
item.Save
Next
End Sub
try deleting the file (save the codes somewhere else first) ... \Documents and Settings\\Application Data\Microsoft\Outlook\VbaProject.OTM

Move outlook mail from one mailbox inbox to different folder in same mailbox

I have several mailboxes which I can see in my Outlook profile. One of the mailboxes, let's call it "Mailbox - HUR" receives messages constantly. presently one of my team goes into the inbox of this mailbox every day and moves (drag and drop) the messages into a subfolder of the inbox called Archive (we're an imaginative lot!) if the messages are greater than 24 hours old.
Is there any way that a macro can be set up to do this task? I know my simple way around VBA but have never used it with Outlook and can't figure out the namespace details to point me to the correct mailbox instead of my mailbox.
Unfortunately I do not have access to Exchange server, only using outlook client.
Any help anyone could give would be great.
You might like to try:
Sub MoveOldEmail()
Dim oItem As MailItem
Dim objMoveFolder As MAPIFolder
Dim objInboxFolder As MAPIFolder
Dim i As Integer
Set objMoveFolder = GetFolder("Personal Folders\Inbox\Archive")
Set objInboxFolder = GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
For i = objInboxFolder.Items.Count - 1 To 0 Step -1
With objInboxFolder.Items(i)
''Error 438 is returned when .receivedtime is not supported
On Error Resume Next
If .ReceivedTime < DateAdd("h", -24, Now) Then
If Err.Number = 0 Then
.Move objMoveFolder
Else
Err.Clear
End If
End If
End With
Next
Set objMoveFolder = Nothing
Set objInboxFolder = Nothing
End Sub
Public Function GetFolder(strFolderPath As String) As MAPIFolder
'' strFolderPath needs to be something like
'' "Public Folders\All Public Folders\Company\Sales" or
'' "Personal Folders\Inbox\My Folder"
Dim objNS As NameSpace
Dim colFolders As Folders
Dim objFolder As MAPIFolder
Dim arrFolders() As String
Dim i As Long
On Error GoTo TrapError
strFolderPath = Replace(strFolderPath, "/", "\")
arrFolders() = Split(strFolderPath, "\")
Set objNS = GetNamespace("MAPI")
On Error Resume Next
Set objFolder = objNS.Folders.Item(arrFolders(0))
If Not objFolder Is Nothing Then
For i = 1 To UBound(arrFolders)
Set colFolders = objFolder.Folders
Set objFolder = Nothing
Set objFolder = colFolders.Item(arrFolders(i))
If objFolder Is Nothing Then
Exit For
End If
Next
End If
On Error GoTo TrapError
Set GetFolder = objFolder
Set colFolders = Nothing
Set objNS = Nothing
Exit_Proc:
Exit Function
TrapError:
MsgBox Err.Number & " " & Err.Description
End Function
You should setup a mailbox rule. Tools | Rules Wizard
If you are using Exchange server have an Outlook rule to move the emails to the specific folder, then use the Mailbox Manager in Exchange to delete messages from that folder after a specific period of time. See this article for more information.
Fionnuala you rock!
I've been looking for a solution to a similar issue for months. With my corporate restrictions, I wasn't able to use the UDF (worked just fine on my personal); Within the sub MoveOldEmail, I instead used:
Set objMoveFolder = GetNamespace("MAPI").PickFolder
Cool thing is that this seems to let me move between email accounts that I have associated with my Outlook (until corp figures out at least).