Articles Tagged: vba

Export All Contacts as vCards January 24, 2009

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.

More...

Process All Outlook Events September 22, 2008

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

Outlook Folder List (Updated) September 22, 2008

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

Automatically Create Contacts June 28, 2007

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

More...

Excel Add-In May 27, 2007

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

More...

Toggle Bullet and Sub-Bullet July 26, 2005

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 July 26, 2005

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

Toggle Under/Overlines July 25, 2005

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

Outlooks Spam Handler July 25, 2005

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.

More...

Select Alternate Columns July 25, 2005

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

License

The contents of this blog are licensed under the Creative Commons “Attribution-Noncommercial-Share Alike 3.0″ license.