Option Explicit ' CREATED BY DUCKY SHERWOOD April 2001 ' Original at http://www.webfoot.com/oeo/outlook/vb/OEOmacros.txt ' Move the selected message(s) to the "done" folder. ************************ Sub MoveToDone() ' Be sure to change the name of the "done" folder to the name of ' *your* "done" folder. MoveToFolder ("zz-Done") End Sub ' Move the selected message(s) to the "to-do" folder. *********************** Sub MoveToToDo() ' Be sure to change the name of the "to-do" folder to the name of ' *your* "done" folder. MoveToFolder ("aa-ToDo") End Sub ' This sends an Up arrow and Alt-Up arrow key to Outlook. ' Up arrow moves the message selection bar up one when the list of ' messages is selected; Alt-Up does the same if a message is ' selected in the Preview pane. This is a bit of a kludge -- ' it sends an two keystrokes when only one is needed -- but the extra ' keystroke doesn't seem to cause any bad side-effects. Furthermore, it ' is really difficult to figure out which of the preview pane and message ' list is active. Sub MessageUp() SendKeys "{UP}", True SendKeys "%{UP}", True End Sub ' Same as MessageUp, but with Down arrows instead. Sub MessageDown() SendKeys "{DOWN}", True SendKeys "%{DOWN}", True End Sub ' Returns TRUE if a folder named folderName is a child of the folder ' named parentFolder, FALSE otherwise. Note that if folderName is in ' a SUBfolder, this will return FALSE. Function FolderExists(parentFolder As MAPIFolder, folderName As String) Dim tmpInbox As MAPIFolder On Error GoTo handleError ' If the folder doesn't exist, there will be an error in the next ' line. That error will cause the error handler to go to :handleError ' and skip the True return value Set tmpInbox = parentFolder.Folders(folderName) FolderExists = True Exit Function handleError: FolderExists = False End Function ' Move the selected message(s) to the given folder ************************** Function MoveToFolder(folderName As String) Dim myOLApp As Application Dim myNameSpace As NameSpace Dim myInbox As MAPIFolder Dim currentMessage As MailItem Dim errorReport As String ' Housekeeping: set up the macro environment Set myOLApp = CreateObject("Outlook.Application") Set myNameSpace = myOLApp.GetNamespace("MAPI") Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox) ' See if the folder exists. If it doesn't, print an informational ' error. If Not FolderExists(myInbox, folderName) Then MsgBox "Folder " & folderName & " does not exist." & _ vbNewLine & vbNewLine & _ "Please either: " & vbNewLine & vbNewLine & vbTab & _ "create the folder " & folderName & " under Inbox" & vbNewLine & _ "or" & vbNewLine & vbTab & _ "change the name of the folder in the Visual Basic code " & _ "that you downloaded. (The name of the folder is well marked, " & _ "near the beginning of the code.)" Exit Function End If ' Figure out if the active window is a list of messages or one message ' in its own window On Error GoTo QuitIfError ' But if there's a problem, skip it Select Case myOLApp.ActiveWindow.Class ' The active window is a list of messages (folder); this means there ' might be several selected messages Case olExplorer ' Move the selected messages to the "done" folder For Each currentMessage In myOLApp.ActiveExplorer.Selection currentMessage.Move (myInbox.Folders(folderName)) Next ' The active window is a message window, meaning there will only ' be one selected message (the one in this window) Case olInspector ' Move the selected message to the "done" folder myOLApp.ActiveInspector.CurrentItem.Move (myInbox.Folders(folderName)) ' can't handle any other kind of window; anything else will be ignored End Select QuitIfError: ' Come here if there was some kind of problem Set myOLApp = Nothing Set myNameSpace = Nothing Set myInbox = Nothing Set currentMessage = Nothing End Function