I have compiled numerous bits of code a quick hacks which I am making available here for anybody who is interested. The code is unmaintained, but I will endeavor to provide any help I can as time permits. All this code was created to complete a specific task and may be written very poorly with little to no documentation.

These are all released under the GPL license

vba code snippets

Excel Add-In

I finally created an add-in for Excel that includes many of the tools that I use all the time and have outlined on this site. The add-in will create a new menu in Excel and setup a number of shortcuts. Here are some of the more useful ones:

  • Ctrl-Shift-C - Automatically color selected cells based on their content (values=blue, formula=black, ref to another sheet=green, offset=red)
  • Ctrl-Shift-U - Toggle an underline for the selected cells
  • Ctrl-Shift-O - Toggle an overline for the selected cells
  • Ctrl-Shift-A - Toggle center (Align) across the selected cells
  • Ctrl-Shift-V - Paste just values
  • Conditional Deletes - Delete any cell/row from the current selection that is a duplicate of the prior cell
  • Format selected cells as multiples (ie, "4.75x") - A toolbar button is added to the format toolbar

To install:

  1. Close Excel
  2. Save the file MVG-Code.xla in C:\Documents and Settings\your-user-id\Application Data\Microsoft\AddIns
  3. Open Excel back up, if you have the "Action" menu after "Help", then you are done. If not, go on to 4.
  4. Go to Tools->Add-Ins and put a check mark by "MVG Custom Macros". If you don't see it in the list, click "Browse" and select MVG-Code.xla. Click OK and you should see a new "Actions" menu.

Hope someone finds these useful. I have been using these for years without any issues, but please let me know if you run into problems.


Automatically Create Contacts

I often find myself creating a Outlook contact from the signature in an email or some text in a work document. Rather than do it by hand each time, I have put together a few vba commands and a new vba class to parse the text on the clipboard and create a new contact from what it gathers.

To set it up, in ThisOutlookSession add:

Public Sub ParseClipboard()
   
Dim Selection As DataObject
   
Dim SelectionStr As String
   
   
Set Selection = New DataObject
   
Selection.GetFromClipboard
   
SelectionStr = Selection.GetText
   
   
CreateAddrFromStr SelectionStr
End Sub

In a new module add:

Option Explicit

Public Sub CreateAddrFromStr(str As String)
   
Dim MyContact As ContactItem
   
Debug.Print "create"
   
Set MyContact = Outlook.CreateItem(olContactItem)
   
MyContact.Display
   
   
Dim MyParsed As ContactObj
   
Set MyParsed = New ContactObj
   
   
Debug.Print str
   
MyParsed.Parse str
   
   
MyContact.FullName = MyParsed.Name
   
MyContact.Title = MyParsed.Title
   
MyContact.CompanyName = MyParsed.Company
   
MyContact.BusinessTelephoneNumber = MyParsed.PhoneWork
   
MyContact.BusinessFaxNumber = MyParsed.PhoneFax
   
MyContact.MobileTelephoneNumber = MyParsed.PhoneMobile
   
MyContact.HomeTelephoneNumber = MyParsed.PhoneHome
   
MyContact.BusinessAddress = MyParsed.Address
   
MyContact.Email1Address = MyParsed.Email1
   
MyContact.Email2Address = MyParsed.Email2
   
MyContact.Email3Address = MyParsed.Email3
   
MyContact.Body = MyParsed.Note
   
End Sub

Then you need to import ContactObj.cls which will create the ContactObj Class Module.

There are a handful of reference that you will need to setup in order to use the regex and pull from the clipboard. In the VBA editor, go to Tools then References and add:

  • Microsoft VBScript Regular Expressions 5.5
  • Microsoft Forms 2.0 Obj Library
  • Microsoft Visual Basic for Applications Extensible 5.5

If MS Forms 2.0 isn't listed, you can browse to c:\windows\system32\fm20.dll.

Finally, you probably want to add a toolbar button to easily use:

  1. Right click on the the toolbar
  2. Click Customize
  3. On the Command tab select Macros on the left, find Project1.ThisOutlookSession.ParseClipboard and drag it to the toolbar

Now a new contact will be created from whatever text you have copied when you click the new button


Export All Contacts as vCards

Outlook has the built in ability to export contacts as vCards, but it will only do it one at a time. With the following vba script and a few bash commands, you can batch export each contact as a vCard and then combine the individual files into one vcard file.

' Copyright under GPL by Mark Grimes
'
Batch export contacts as vCards
Sub ExportVCards()

   
Dim objNS As NameSpace
   
Dim objFolders, objFolder, objContactFolder
   
Dim objEntry As Variant
   
Dim objContactEntry As ContactItem
   
Dim count As Integer
   
    count
= 0
   
   
Set objNS = Application.GetNamespace("MAPI")
   
Set objContactFolder = objNS.GetDefaultFolder(olFolderContacts)
   
' Set objCalFolder = objNS.Folders.item("Mailbox - Mark").Folders.item("Calendar")
   
    For Each objEntry In objContactFolder.Items
        If Not TypeOf objEntry Is ContactItem Then
            If TypeOf objEntry Is DistListItem Then
                Debug.Print "Found a distribution list, skipping"
            Else
                Debug.Print "****** found a something odd ****"
                Debug.Print "  " & objEntry
            End If
        Else
       
            Set objContactEntry = objEntry
            count = count + 1
            Debug.Print count & ": " & objContactEntry.Subject
           
            path = "/tmp/contacts/contact" & count & ".vcf"
            objContactEntry.SaveAs path, olVCard
        End If
    Next
    Set objNS = Nothing

End Sub

And a few bash commands to combine the files into one:

cd /tmp/contacts
cat contacts*.vcf > outlook-contacts.vcf
rm -f contacts*.vcf

Miquel Aguado suggested the following win/dos batch command to create a single file:

c:> type c:\temp\contacts\contact*.vcf >> c:\temp\contacts\allcontacts.vcf

And he generously provided these modifications to the subroutine to have the command called directly from Outlook. I have not tested this, but it looks like it would work just fine.

# -----------
# Put the following before the for-loop
   
Dim strOutputDirectory, strOutputFilePrefix, strOutputFileSuffix As String
   strTypeCommand
= "c:\windows\system32\cmd.exe /c "
   strOutputDirectory
= "c:\temp\contacts\"
   strOutputFilePrefix = "
contact"
   strOutputFileSuffix = "
.vcf"
   strOutputFileName = "
allContacts.vcf"
# code end
# -----------
# modify the assignment to var path with the following
   Path = strOutputDirectory & strOutputFilePrefix & count & strOutputFileSuffix
# code end
# -----------
# Put the following at the end of the method
   Dim strCommand As String
   strCommand = strTypeCommand & "
""" & strOutputDirectory &
                strOutputFilePrefix & "
*" & strOutputFileSuffix & """ >> """ &
                strOutputDirectory & strOutputFileName & """"
   Debug.Print strCommand
   Call Shell(strCommand, 0)
# code end
# -----------

Auto Color Cells

Many users of Excel have made it common practice to color code cells to help identify inputs, formulas, etc. For example, it is common to color all cells act as hard coded inputs (i.e. not a formula) blue, all formulas black. This Excel macro looks at the contents of each selected cell and sets the color appropriately. Further I have added the green coloring for all external references.

' Set the color of cells to blue or black respectively
'
Copyright under GPL by Mark Grimes
' Keyboard Shortcut: Crtl+Shift+C

Sub mgSetColor()
    For Each c In Selection.Cells
        If Left(c.Formula, 1) = "=" Then
            If InStr(c.Formula, ".xls") Or InStr(c.Formula, ".XLS") Then
                c.Font.ColorIndex = 10
            ElseIf InStr(c.Formula, "OFFSET") Then
                c.Font.ColorIndex = 9
            Else
                allNumbers = True
                For i = 1 To Len(c.Formula) - 1
                    If (Asc(Mid(c.Formula, i, 1)) < 40) Or (Asc(Mid(c.Formula, i, 1)) > 61) Then
                        '
MsgBox "Setting false: " & Mid(c.Formula, i, 0) & " = " & Asc(Mid(c.Formula, i, 1))
                        allNumbers
= False
                       
Exit For
                   
Else
                       
' MsgBox Mid(c.Formula, i, 1) & " = " & Asc(Mid(c.Formula, i, 1))
                    End If
                Next
                If allNumbers Then
                    c.Font.ColorIndex = 5   '
blue
               
Else
                    c
.Font.ColorIndex = 0   ' auto
                End If
            End If
        Else
            c.Font.ColorIndex = 5
        End If
    Next
End Sub

Forward E-Mails as They Are Sorted

I often find myself creating a folder to store all the messages relating to a particular project, and then wanting to forward any message placed in that folder to one of my colleagues. This code, when placed in the ThisOutlookSession module, takes care of the forwarding for me.

This code was derived from Sue Mosher's article found in Windows & .Net Magazine.

' Copyright under GPL by Mark Grimes

Option Explicit

Private WithEvents objEconomistItems As Items

'
instantiate Items collections for folders we want to monitor
Private Sub Application_Startup()
   
Dim objNS As NameSpace
   
Set objNS = Application.GetNamespace("MAPI")

   
Set objEconomistItems = objNS.GetDefaultFolder(olFolderInbox).Folders.Item("Mailing Lists").Folders.Item("Economist").Items
   
Set objNS = Nothing
End Sub

' disassociate global objects declared WithEvents
Private Sub Application_Quit()
    Set objEconomistItems = Nothing
End Sub

'
Forward msg when new msg added to folder
' Prompt before sending
Private Sub objEconomistItems_ItemAdd(ByVal Item As Object)
    Dim Response As Variant
    Dim myForward As Variant

    Response = MsgBox("Forward message (" + Item.Subject + ") to Patrick & Josh?", vbYesNo)
    If Response = vbYes Then
        Set myForward = Item.Forward
        myForward.Recipients.Add "Patrick (E-mail)"
        myForward.Recipients.Add "Josh (E-Mail)"
        myForward.Send
    End If
End Sub

Toggle Under/Overlines

When formatting a Excel sheet underlining or overlining (which appears as if you underlined the cell above) a cell often looks much better than just underlining the contents of the cell (ctrl-u). This macro will toggle the under/overlines for all the selected sells.

' Toggles Underlines
'
[% coypright %]
' Keyboard Shortcur: Crtl+Shift+U
'

Sub mgSetUnderline()
   
If Selection.Borders(xlBottom).LineStyle = xlNone Then
       
With Selection.Borders(xlBottom)
           
.Weight = xlThin
           
.ColorIndex = xlAutomatic
       
End With
   
Else
       
Selection.Borders(xlBottom).LineStyle = xlNone
   
End If
End Sub
' Toggles Overlines
'
Copyright under GPL by Mark Grimes
' Keyboard Shortcur: Crtl+Shift+O
'

Sub mgSetAnOverline()
   
If Selection.Borders(xlTop).LineStyle = xlNone Then
       
With Selection.Borders(xlTop)
           
.Weight = xlThin
           
.ColorIndex = xlAutomatic
       
End With
   
Else
       
Selection.Borders(xlTop).LineStyle = xlNone
   
End If
End Sub

Outlook Folder List

For the previous hack, I often had a hard time finding the correct folder to monitor. This bit of code will list all the top level folders for you.

' Copyright under GPL by Mark Grimes
'
list folders by poping up msg box windows
Private Sub ListFolders()
   
Dim objNS As NameSpace
   
Dim objFolders, objFolder
   
Set objNS = Application.GetNamespace("MAPI")

   
' instantiate Items collections for folders we want to monitor
    Set objFolders = objNS.Folders
    For Each objFolder In objFolders
        MsgBox objFolder.Name
    Next
    Set objNS = Nothing
End Sub

Create Spacing Rows

I often want to have some space between row to call attention to a particular row, but rather than having a full row, a small row would work better. This macro will adjust the height of all the select cells if they are empty.

' Set the height of all blank selected rows to small
'
Copyright under GPL by Mark Grimes
' Keyboard Shortcur: Crtl+Shift+E
'

Sub mgShrinkSpaces()
   
For Each c In Selection.Cells
       
If c.Value = "" Then
            c
.RowHeight = 5
       
End If
   
Next
End Sub

Outlook Folder List (Updated)

Again, I needed to find the path to particular folder. This one was deep and not under my Inbox. So, updated the folder list function. It is now recursive and (very simply) shows the structure.

' Copyright under GPL by Mark Grimes
'
list folders by poping up msg box windows
Sub ListFolders()
   
Dim objNS As NameSpace
   
Dim objFolder
   
   
Set objNS = Application.GetNamespace("MAPI")
   
ListFromFolder objNS, ""
   
Set objNS = Nothing
End Sub

Sub ListFromFolder(objFolderRoot, spaces As String)
   
Dim objFolder As MAPIFolder
           
   
For Each objFolder In objFolderRoot.Folders
       
Debug.Print spaces + objFolder.Name
       
If objFolder.Folders.count > 0 Then
           
ListFromFolder objFolder, spaces + " "
       
End If
   
Next
End Sub

Align Center

I hate merged cells. They create all sorts of problems adding/deleting columns, filling down, etc. But it can look nice to have text centered across a range not just a single cell. Luckily, Excel provides the rarely used Align Center formatting option. This macro provides easy access to toggling the alignment formatting across all selected cells... but that's not all... :-) it also centers the contents of a single cell if that is all that is selected.

' Toggles Align Center
'
Copyright under GPL by Mark Grimes
' Keyboard Shortcur: Crtl+Shift+A
'

Sub mgCenterAlign()
   
If Selection.count = 1 Then
       
With Selection
           
If .HorizontalAlignment = xlHAlignCenter Then
               
.HorizontalAlignment = xlGeneral
           
Else
               
.HorizontalAlignment = xlHAlignCenter
           
End If
       
End With
   
Else
       
With Selection
           
If .HorizontalAlignment = xlCenterAcrossSelection Then
               
.HorizontalAlignment = xlGeneral
           
Else
               
.HorizontalAlignment = xlCenterAcrossSelection
           
End If
       
End With
   
End If
End Sub

Process All Outlook Events

I recently needed to walk through all the events in an Outlook calendar and make a change. Here is the simple code:

' Copyright under GPL by Mark Grimes
'
list folders by poping up msg box windows
Sub ResaveCalendarEntries()

   
Dim objNS As NameSpace
   
Dim objFolders, objFolder, objCalFolder
   
Dim objCalEntry As AppointmentItem

   
Dim count
    count
= 0
   
   
Set objNS = Application.GetNamespace("MAPI")
   
Set objCalFolder = objNS.Folders.item("Mailbox - MyMailBox").Folders.item("Calendar")
       
' This also works...
    '
Set objCalFolder = objNS.GetDefaultFolder(olFolderCalendar)
   
   
For Each objCalEntry In objCalFolder.Items
        count
= count + 1
       
Debug.Print count
       
Debug.Print objCalEntry.Subject
       
        objCalEntry
.Mileage = 1
        objCalEntry
.Save
       
' Exit Sub
    Next
    Set objNS = Nothing

End Sub

Toggle Bullet and Sub-Bullet

When I feel like getting fancy, it can be nice to include a bulleted list in an Excel sheet to describe assumptions, etc. This is actually pretty easy to do, but requires adding some odd characters. This macro will add a character and change the font of a cell to create a bullet. If you run this macro on a cell which already contains a bullet, an arrow shaped sub-bullet is inserted instead.

' Toggles a bullet and an arrow
'
Copyright under GPL by Mark Grimes
' Keyboard Shortcut: Crtl+Shift+B
'

Sub mgBullet()
   
If ActiveCell.Formula = "l" Then
       
Selection.Font.Name = "Wingdings"
       
ActiveCell.FormulaR1C1 = "bullet"
               
' Replace the text bullet with the bullet symbole from Wingdings
        '
Found that others don't have wingdings 3, it's sub-bullet was better
       
' Selection.Font.Name = "Wingdings 3"
        '
ActiveCell.FormulaR1C1 = "}"
   
Else
       
Selection.Font.Name = "Wingdings"
       
ActiveCell.FormulaR1C1 = "l"
   
End If
   
   
With Selection
       
.HorizontalAlignment = xlCenter
       
.VerticalAlignment = xlBottom
       
.WrapText = False
       
.Orientation = xlHorizontal
   
End With
End Sub

Backup Current File

This is one of my favorites. It saves a copy of the current file in the 'Backup' directory if one exists under the directory in which the file is currently saved. It saves the files with an incrementing two digit number after the filename (before the .xls extension). A cap of 50 backups is imposed just to keep from taking up too much disk space (my models tend to be BIG).

' Save a copy of the current file.
'
Copyright under GPL by Mark Grimes
' Keyboard Shortcut: Crtl+Shift+S
'
   Will save in the "Backup" subdirectory if it exists.
'    Will attempt to add an index number upto 50.
'

Sub mgSaveBackup()
    p0$
= ActiveWorkbook.Path
   
If Dir(p0$ & "\Backup", vbDirectory) <> "" Then
        p$
= p0$ & "\Backup"
   
End If
   
    n0$
= ActiveWorkbook.Name
   
If Right(n0$, 4) <> ".xls" And Right(n0$, 4) <> ".XLS" Then
       
MsgBox "File must be a previously saved '.xls' file."
       
End
   
End If
    n$
= Left(n0$, Len(n0$) - 4)
   
    i
= 0
   
Do
        i
= i + 1
   
Loop Until (Dir(p$ & "\" & n$ & "." & Application.Text(i, "00") & ".xls") = "") Or (i > 50)
   
    If i > 50 Then
        MsgBox "
No more than 50 backup's can be made."
        End
    End If
   
    response = MsgBox("File to be backed-up as:" & Chr(10) _
            & p$ & "\" & n$ & "." & Application.Text(i, "00") & ".xls", vbOKCancel)
       
    If response = vbOK Then
        '
FileCopy p0$ & "\" & n0$, p$ & "\" & n$ & "." & i & ".xls"
        ActiveWorkbook.SaveCopyAs p$ & "
\" & n$ & "." & Application.Text(i, "00") & ".xls"
    Else
        MsgBox "
Backup aborted!"
    End If
End Sub

Select Alternate Columns

I often like to have narrow empty columns between data columns just to make things look nice (cell underlining looks better that way in my opinion). This macro will prompt you for a number of columns per group and then it selects one column per group for the currently selected range (i.e. selecting A5:G5, running the macro and entering 2 would result in columns B, D, and F being selected). Then you can quickly resize those columns to make everything look real pretty.

'
'
Select every other column
' Copyright under GPL by Mark Grimes
'

Sub mgSelectEOther()
   
Dim i, mult As Integer
   
Dim r, cst As String
   
    mult
= Application.InputBox(prompt:="Select every x columns:", default:=2, Type:=1)
   
    r
= ""
    i
= 0
   
For Each c In Selection
        i
= i + 1
       
If i Mod mult = 0 Then
           
If (c.Column > 26) Then
               
' tx = c.Column & ": A=" & Asc("A") & ", " & Int(c.Column / 26) & ", " & (c.Column Mod 26)
                '
MsgBox tx
                cst
= Chr(Asc("A") - 1 + Int(c.Column / 26)) & Chr(Asc("A") + (c.Column Mod 26) - 1)
           
Else
                cst
= Chr(Asc("A") + c.Column - 1)
           
End If
            r
= r & "," & cst & ":" & cst
       
End If
   
Next
    r
= Right(r, Len(r) - 1)
   
' MsgBox r
    ActiveSheet.Range(r).Select
End Sub

Outlooks Spam Handler

The spam filters that we use at work, process all the messages in a particular folder to train the filter. Rather than drag and drop messages, I use the following code to move the selected or active message into the target folder. For each of the public subs, I have a toolbar button which runs the code.

' Copyright under GPL by Mark Grimes

'
Move selected mail to spam training folder
Public Sub Spam()
   
Dim objSelection    As Variant
   
Dim objDestFolder   As MAPIFolder

   
Debug.Print "MoveToSpam..."

   
Set objSelection = GetSelection
   
Set objDestFolder = GetFolder("This is spam email")
   
ProcessMessages objSelection, objDestFolder, True

   
Debug.Print "Done"
End Sub

' Move selected mail to ham training folder
Public Sub Ham()
    Dim objSelection    As Variant
    Dim objDestFolder   As MAPIFolder

    Debug.Print "CopyToHam..."

    Set objSelection = GetSelection
    Set objDestFolder = GetFolder("This is legitimate email")
    ProcessMessages objSelection, objDestFolder, False

    Debug.Print "Done"
End Sub

'
Move selected mail to whilelist training folder
Public Sub Whitelist()
   
Dim objSelection    As Variant
   
Dim objDestFolder   As MAPIFolder

   
Debug.Print "Whitelist..."

   
Set objSelection = GetSelection
   
Set objDestFolder = GetFolder("Add to whitelist")
   
ProcessMessages objSelection, objDestFolder, False

   
Debug.Print "Done"
End Sub

' Return a collection which holds all the selected emails
Private Function GetSelection()
    Dim objApp, objSelection

    Set objApp = CreateObject("Outlook.Application")
    Set objSelection = objApp.ActiveExplorer.Selection
    Debug.Print "  got " & objSelection.Count & " items"

    Set GetSelection = objSelection
End Function

'
Return the folder which we will move mail to
Private Function GetFolder(folder As String)
   
Dim objNS           As NameSpace
   
Dim objDestFolder   As MAPIFolder

   
Set objNS = Application.GetNamespace("MAPI")
   
Set objDestFolder = objNS.Folders.Item("Public Folders").Folders.Item("All Public Folders").Folders.Item("GFI AntiSpam Folders").Folders.Item(folder)
   
Set GetFolder = objDestFolder
End Function

' Move or copy all the messages in the collection into the designated folder
Private Sub ProcessMessages(objSelection As Variant, objDestFolder As MAPIFolder, move As Boolean)
    Dim myItem As Object
    Dim myCopiedItem As Object

    For Each myItem In objSelection
        If Not (TypeOf myItem Is MailItem) Then
            Debug.Print "  item is not an email"
        Else
            If move Then
                Debug.Print "  moving item"
                myItem.move objDestFolder
            Else
                Debug.Print "  copying item"
                Set myCopiedItem = myItem.Copy
                myCopiedItem.move objDestFolder
            End If
        End If
    Next
End Sub

'
Move current email to Spam folder
' Called from an open email rather than the list
Public Sub ThisIsSpam()
    Dim objSelection    As Variant
    Dim objDestFolder   As MAPIFolder

    Debug.Print "MoveToSpam..."

    Set objSelection = GetCurrentItem
    Set objDestFolder = GetFolder("This is spam email")
    ProcessMessages objSelection, objDestFolder, True

    Debug.Print "Done"
End Sub

'
Return the current email as the sole member of a collection
Private Function GetCurrentItem()
   
Dim objApp, objSelection, objItem

   
Set objApp = CreateObject("Outlook.Application")
   
Set objItem = objApp.ActiveInspector.CurrentItem
   
Set objSelection = New Collection
    objSelection
.Add objItem
   
Debug.Print "  got " & objSelection.Count & " items"

   
Set GetCurrentItem = objSelection
End Function

Outlook Junk Mail - Old

The following code worked for older versions of Outlook (2000 I believe), but does not work for newer versions. There used to be a junk button on the toolbar. The code effectively activated that button. I'm not sure how to do it in newer version of Outlook. I have actually given up on Outlook's spam filtering and use SpamAssassian now. You might check out Wininspector to track down the right object.

If anyone figures out a solution, please email me know. I have had several people ask about this.

This code combines the frequently used steps of adding the senders of all selected e-mails to the Outlook "Junnk Sender's List" and then moving the messages to the junk mail folder. I then create a toolbar button associated with this "macro."

The core of which is based on code from Sue Mosher's article in Windows & .Net Magazine and the kludge to access the unpublished "Add to Junk Senders" is from Rick Pearce's post to the microsoft.public.outlook.program_vba newsgroup.

' Copyright under GPL by Mark Grimes

Sub DealJunkMail()
    Dim objApp As Application
    Dim objSelection As Selection
    Dim blnDoIt As Boolean
    Dim intMaxItems As Integer
    Dim intOKToExceedMax As Integer
    Dim strMsg As String

    '
### set your maximum selection size here ###
    intMaxItems
= 5

   
Set objApp = CreateObject("Outlook.Application")
   
Set objSelection = objApp.ActiveExplorer.Selection
   
Select Case objSelection.Count
       
Case 0
            strMsg
= "No items were selected"
           
MsgBox strMsg, , "No selection"
            blnDoIt
= False
       
Case Is > intMaxItems
            strMsg
= "You selected " & _
                objSelection
.Count & " items. " & _
               
"Do you really want to process " & _
               
"that large a selection?"
            intOKToExceedMax
= MsgBox( _
               
Prompt:=strMsg, _
               
Buttons:=vbYesNo + vbDefaultButton2, _
               
Title:="Selection exceeds maximum")
           
If intOKToExceedMax = vbYes Then
                blnDoIt
= True
           
Else
                blnDoIt
= False
           
End If
       
Case Else
            blnDoIt
= True
   
End Select
   
If blnDoIt = True Then

       
' ### set the procedure to run on the selection here ###
        Call AddToJunkAndMove(objSelection)

        Beep '
alert the user that we're done
        '
MsgBox "All done!", , "Selection"
   
End If
   
Set objSelection = Nothing
   
Set objApp = Nothing

End Sub

Sub AddToJunkAndMove(objSel As Selection)
   
Dim objItem As Object
   
Dim objNS As NameSpace
   
Dim objDestFolder As MAPIFolder
   
Dim myOlApp As Outlook.Application

   
Set objNS = Application.GetNamespace("MAPI")
   
Set objDestFolder = objNS.Folders.Item("Mailbox - Mark Grimes").Folders.Item("Junk E-mail")

   
Set myOlApp = CreateObject("Outlook.Application")
   
Dim ctl As CommandBarControl ' Junk E-mail flyout menu
    Dim subctl As CommandBarControl '
Add to Junk Senders list menu

   
Set ctl = myOlApp.ActiveExplorer.CommandBars.FindControl(Type:=msoControlPopup, ID:=31126)
   
Set subctl = ctl.CommandBar.Controls(1)
   
'MsgBox subctl.Caption
    subctl.Execute

    For Each objItem In objSel
        If objItem.Class = olMail Then
            objItem.Move objDestFolder
        End If
    Next
    Set objDestFolder = Nothing
    Set objNS = Nothing
    Set objItem = Nothing
End Sub

Combine Cells

This routine combines the selected cells into one long string in the current cell.

' Combine cells
'
Copyright under GPL by Mark Grimes

Sub mgCombineCells()
    t
= ""
   
For Each c In Selection.Cells
        t
= t & Trim(c.Formula) & " "
   
Next
    t
= Left(t, Len(t) - 1)
   
ActiveCell.Formula = t
End Sub

Swap Note and Formula

Here are two routines that pull the formula from a note and put the formula in a note. I had a very specific need for this, but I can't recall why now.

' Creates a formula from the Note
'
Copyright under GPL by Mark Grimes

Sub mgNote2Formula()
   
For Each c In Selection.Cells
        c
.Formula = c.NoteText
   
Next
End Sub

'
'
Put the formula in the note
' Copyright under GPL by Mark Grimes
Sub mgFormulaToNote()
    For Each c In Selection.Cells
        c.NoteText (c.Formula)
    Next
End Sub

Main

outlook

cygwin

perl

spam

vba

websites

excel

applescript

mac