Export Outlook Contacts to Excel

September 6, 2008 – 9:02 pm

    Here is the last of the add-in code I was working on. This piece extracts the properties from Contact Items into Excel, using early binding to speed up the code, but with GetObject/CreateObject calls to attempt to hook into an existing instance of Outlook. What, do you mean you don’t leave Outlook running all day while you’re in the office?

    This code uses the same technique from the Tasks extracting code I posted earlier, so this code below should look pretty familiar to you if you check out that post. An array is populated with the contact information, which is then dumped in one shot to the worksheet.

    Something seems to be wrong with my code syntax highlighter, you’ll need to cut and paste the code in order to view it proper. It does cut and paste properly, even though you can’t view it all.

    I haven’t tested this but it should work as written. This code is just a demonstration with three fields (Company name, Country and Phone Number). If you want to export more fields, look up the properties of the ContactItem here.

    I also included some additional code at the bottom which can be used in other routines to prompt the user to save the file, with a sample filename, filter and title so you can see how code like that would work. It also handles the possibility that the user clicks “Yes” to save the file, but then presses Cancel in the file save dialog box (or doesn’t type anything and presses OK).

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
Sub ExtractContacts()
'
' If Outlook is not open, it still works, but much slower (~8 secs vs. 2 secs w/ Outlook open).
'
Dim olApp As Outlook.Application
Dim olNS As Outlook.Namespace
Dim myContactItems As Outlook.Items
Dim ThisContact As Outlook.ContactItem
Dim MyBook As Excel.Workbook
Dim rngStart As Excel.Range
Dim rngHeader As Excel.Range
Dim FileToSave As String
Dim NextRow As Long
Dim ColCount As Long
Dim i As Long
Dim arrData() As Variant
 
Application.ScreenUpdating = False
 
' get or create Outlook object and make sure it exists before continuing
On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
If Err.Number <> 0 Then
  Set olApp = CreateObject("Outlook.Application")
End If
On Error GoTo 0
If olApp Is Nothing Then
  MsgBox "Cannot start Outlook.", vbExclamation, APPNAME
  GoTo ExitProc
End If
 
Set olNS = olApp.GetNamespace("MAPI")
Set myContactItems = olNS.GetDefaultFolder(olFolderContacts).Items
 
If myContactItems.Count > 0 Then
 
  Set MyBook = Excel.Workbooks.Add
  MyBook.Sheets(1).Name = "Contacts"
  Set rngStart = MyBook.Sheets(1).Range("A1")
  Set rngHeader = Range(rngstart, rngstart.Offset(0,3))
 
  ' with assistance from Jon Peltier http://peltiertech.com/WordPress and
  ' http://support.microsoft.com/kb/306022
 
  rngHeader.Value = Array("Company Name", "Country", "Telephone Number")
 
  ColCount = rngHeader.Columns.Count
 
  ' now that we know how many rows and columns we need,
  ' resize the array accordingly
  ReDim arrData(1 To myContactItems.Count, 1 To ColCount)
 
'
' to make it more obvious:
' Dim LastRow As Long
' Dim LastColumn As Long
' LastRow = myContactItems.Count
' LastColumn = rngHeader.Columns.Count
' ReDim arrData( 1 to LastRow, 1 to LastColumn)
'
'
  For i = 1 to myContactItems.Count
    Set ThisContact = myContactItems.item(i)
 
    arrData(i, 1) = ThisContact.CompanyName
    arrData(i, 2) = ThisContact.HomeAddressCountry
    arrData(i, 3) = ThisContact.BusinessTelephoneNumber
 
  Next i
 
  rngStart.Offset(1, 0).Resize(myContactItems.Count, ColCount).Value = arrData
 
 
Else
  MsgBox "I don't see any contacts in your default Contacts folder. Exiting now...", vbOKOnly, APPNAME
End If
 
If MsgBox("Would you like to save the exported contacts list now?", vbInformation + vbYesNo) = vbYes Then
  FileToSave = Application.GetSaveAsFilename("Outlook Contacts", FileFilter:="Microsoft Office Excel Workbook (*.xls), *.xls", Title:="Save File")
      If FileToSave <> False Then
        ActiveWorkbook.SaveAs FileToSave, FileFormat:=xlNormal
      End If
End If
 
ExitProc:
Application.ScreenUpdating = True
Set ThisContact = Nothing
Set rngStart = Nothing
Set MyBook = Nothing
Set olNS = Nothing
Set olApp = Nothing
Set myContactItems = Nothing
Erase arrData
End Sub

Enjoy,
JP

Reading worksheet values into arrays

September 6, 2008 – 8:10 pm

I’ve been exploring more with arrays and working with them in code, and I found a page in the MS KB that gives some sample code: Sample Visual Basic macros for working with arrays in Excel (FYI this page is in the VBA search engine). I was inspired in part by some of the work I’d done previously with arrays, and also some newsgroup postings about interactions between VBA and Excel.

I thought I’d share some of the code with you in case you needed to do something in VBA with worksheet values, and wanted it done quickly and efficiently. Apparently, VBA and Excel don’t necessarily work well together; worksheet calls in VBA are very costly (relatively speaking), as explained in this post. If your workbook primarily uses VBA to complete its purpose, you’ll want to limit the amount of worksheet calls as much as possible; in a perfect situation, to just two: reading the input data into an array, and writing back the completed data in one shot.

That’s where arrays come in. In response to a recent newsgroup posting, I posted the following code which reads the contents of a worksheet range into a VBA array:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
Sub Read_Into_Array()
 
Dim arrData() As Variant
Dim ColACount As Long
 
Dim i As Long
 
ColACount = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp)).Count
 
ReDim arrData(1 To ColACount, 1 To 2)
 
  For i = 1 To ColACount
    arrData(i, 1) = Range("A" & i).Value
    arrData(i, 2) = Range("B" & i).Value
  Next i
 
End Sub

But according to the MS KB article, all I really needed to do was this:

1
2
3
4
5
6
7
Sub Readinto_array()
 
Dim arrData() As Variant
 
arrData = Range("A1:B29").Value
 
End Sub

I tested it and it seems to work exactly the same. I’d be curious to know, memory and efficiency wise, how the arrData variable looks. The first sub strictly delimits its size, while the second one just pushes the range into it.

Enjoy,
JP

The ultimate in lazy emailing?

September 6, 2008 – 4:25 pm

Lately I’ve been getting tired of writing a greeting line in every message I send (50-60 per day).

I know that writing someone’s name (or a greeting line like “Hello”) seems trivial, but it adds up when you send as many emails as I do. It just gets annoying and tiring, especially if you don’t mean it :)

Yes, that is how I get a lot of my ideas; just doing something over and over and thinking, “there’s got to be a better way.” So I adjusted the code found here to insert a greeting line at the top of every email.

I wrote two versions; one for “Reply” and another for “Reply To All”. All you do is add these subs to a module in Outlook, then set up a toolbar button to call each macro (see Resend This Message page for instructions). When the subs run, you just press 1 if you want to insert the recipient’s name at the top, or press 2 if you want a standard greeting line (which self-adjusts depending on time of day). Also if you use the “Reply To All” code, be sure to replace my name with yours (or whatever display name you use to send email from), so you don’t send a copy of the message to yourself.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
Sub InsertNameInReply()
 
Dim Msg As Outlook.MailItem
Dim MsgReply As Outlook.MailItem
Dim strGreetName As String
Dim lGreetType As Long
 
' set reference to open/selected mail item
On Error Resume Next
Select Case TypeName(Application.ActiveWindow)
    Case "Explorer"
        Set Msg = ActiveExplorer.Selection.Item(1)
    Case "Inspector"
        Set Msg = ActiveInspector.CurrentItem
    Case Else
End Select
On Error GoTo 0
 
If Msg Is Nothing Then GoTo ExitProc
 
' figure out greeting line
On Error Resume Next
lGreetType = InputBox("How to greet:" & vbCr & vbCr & "Type '1' for name, '2' for time of day")
On Error GoTo 0
 
If (lGreetType <> 1) And (lGreetType <> 2) Then GoTo ExitProc
 
If lGreetType = 1 Then
  strGreetName = Left$(Msg.SenderName, InStr(1, Msg.SenderName, " ") - 1)
ElseIf lGreetType = 2 Then
  Select Case Time
    Case Is < 0.5
      strGreetName = "Good morning"
    Case 0.5 To 0.75
      strGreetName = "Good afternoon"
    Case Else
      strGreetName = "Good evening"
  End Select
End If
 
Set MsgReply = Msg.Reply
 
With MsgReply
  .Subject = "RE:" & Msg.Subject
  .HTMLBody = strGreetName & "," & "<br />" & .HTMLBody
  .Display
End With
 
ExitProc:
Set Msg = Nothing
Set MsgReply = Nothing
strGreetName = vbNullString
End Sub
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
Sub InsertNameInReplyToAll()
 
Dim Msg As Outlook.MailItem
Dim MsgReply As Outlook.MailItem
Dim strGreetName As String
Dim sRecipient As Outlook.Recipient
Dim lGreetType As Long
 
' set reference to open/selected mail item
On Error Resume Next
Select Case TypeName(Application.ActiveWindow)
    Case "Explorer"
        Set Msg = ActiveExplorer.Selection.Item(1)
    Case "Inspector"
        Set Msg = ActiveInspector.CurrentItem
    Case Else
End Select
On Error GoTo 0
 
If Msg Is Nothing Then GoTo ExitProc
 
' figure out greeting line
On Error Resume Next
lGreetType = InputBox("How to greet:" & vbCr & vbCr & "Type '1' for name, '2' for time of day")
On Error GoTo 0
 
If (lGreetType <> 1) And (lGreetType <> 2) Then GoTo ExitProc
 
If lGreetType = 1 Then
  strGreetName = Left$(Msg.SenderName, InStr(1, Msg.SenderName, " ") - 1)
ElseIf lGreetType = 2 Then
  Select Case Time
    Case Is < 0.5
      strGreetName = "Good morning"
    Case 0.5 To 0.75
      strGreetName = "Good afternoon"
    Case Else
      strGreetName = "Good evening"
  End Select
End If
 
Set MsgReply = Msg.Reply
 
With MsgReply
 
    ' add original recipient(s) to CC field
    For Each sRecipient In Msg.Recipients
      If sRecipient.Name <> "Jimmy Pena" Then
        Set sRecipient = .Recipients.Add(sRecipient.Name)
        With sRecipient
            .Type = olCC
            .Resolve
        End With
      End If
    Next sRecipient
 
  .Subject = "RE:" & Msg.Subject
  .HTMLBody = strGreetName & "," & "<br />" & .HTMLBody
  .Display
End With
 
ExitProc:
Set Msg = Nothing
 
Set MsgReply = Nothing
strGreetName = vbNullString
End Sub

Enjoy,
JP

Export Outlook Tasks to Excel

August 29, 2008 – 12:20 pm

    Here is part of the add-in code that exports Outlook Tasks into Excel. It works the same as the previous code that exports Calendar items, except we set a reference to the default Tasks folder (not Calendar), and I’ve also incorporated some new code which makes the sub more efficient by writing the data to an array, which is then dumped to the worksheet in one pass.

    Note that the Object Model Guard (OMG) is in play here, depending on the properties you reference. For example, the Body Property of a TaskItem in the code below will trigger the OMG. There are probably other properties that will also trigger the OMG, like trying to access the names or email addresses of anyone associated with the task (Owner, Status update recipients, etc).

    The code below (and the code to export Calendar items) can be ported to Outlook almost as-is, which should avoid the OMG. In fact, I went ahead and did so with the Tasks code, and the Body Property did not trigger the OMG. :)

Excel version:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
Sub GetTasksData(StartDate As Date, Optional EndDate As Date)
 
' -------------------------------------------------
' Notes:
' If Outlook is not open, it still works, but much slower (~8 secs vs. 2 secs w/ Outlook open).
' End Date is optional, if you want to pull from only one day, use: Call GetTasksData("7/14/2008")
' -------------------------------------------------
 
Dim olApp As Outlook.Application
Dim olNS As Outlook.Namespace
Dim myTaskItems As Outlook.Items
Dim ItemstoCheck As Outlook.Items
Dim ThisTask As Outlook.TaskItem
 
Dim rng As Excel.Range
Dim rngStart As Excel.Range
Dim rngHeader As Excel.Range
Dim MyBook As Excel.Workbook
 
Dim i As Long
Dim NextRow As Long
Dim ColCount As Long
 
Dim MyItem As Object
Dim StringToCheck As String
Dim arrData() As Variant
 
Application.ScreenUpdating = False
 
' if no end date is specified, EndDate variable will be "12:00:00 AM"
' the requestor only wants one day, so set EndDate = StartDate
If EndDate = "12:00:00 AM" Then
    EndDate = StartDate
End If
 
If EndDate < StartDate Then
    MsgBox "Those dates seem switched, please check them and try again.", vbInformation
    GoTo ExitProc
End If
 
If EndDate - StartDate > 28 Then
    ' ask if the requestor wants so much info
    If MsgBox("This could take some time. Continue anyway?", vbInformation + vbYesNo) = vbNo Then
        GoTo ExitProc
    End If
End If
 
' get or create Outlook object and make sure it exists before continuing
On Error Resume Next
    Set olApp = GetObject(, "Outlook.Application")
    If Err.Number <> 0 Then
        Set olApp = CreateObject("Outlook.Application")
    End If
On Error GoTo 0
If olApp Is Nothing Then
    MsgBox "Cannot start Outlook.", vbExclamation
    GoTo ExitProc
End If
 
' hook into default Tasks folder
Set olNS = olApp.GetNamespace("MAPI")
Set myTaskItems = olNS.GetDefaultFolder(olFolderTasks).Items
 
' ------------------------------------------------------------------
' the following code adapted from:
' http://www.outlookcode.com/article.aspx?id=30
' http://weblogs.asp.net/whaggard/archive/2007/03/21/retrieving-your-
' outlook-appointments-for-a-given-date-range.aspx
'
With myTaskItems
    .Sort "[StartDate]", False
    .IncludeRecurrences = True
End With
'
StringToCheck = "[StartDate] >= " & Quote(StartDate) & " AND [DueDate] <= " & Quote(EndDate)
Debug.Print StringToCheck
'
Set ItemstoCheck = myTaskItems.Restrict(StringToCheck)
Debug.Print ItemstoCheck.Count
' ------------------------------------------------------------------
 
If ItemstoCheck.Count > 0 Then
    ' we found at least one task
    ' check to make sure we have actual tasks, not infinite recurrence issues
    If ItemstoCheck.item(1) Is Nothing Then GoTo ExitProc
 
    Set MyBook = Excel.Workbooks.Add
    MyBook.Sheets(1).Name = Format(StartDate, "MMDDYYYY") & " - " & Format(EndDate, "MMDDYYYY")
    Set rngStart = MyBook.Sheets(1).Range("A1")
 
    Set rngHeader = Range(rngStart, rngStart.Offset(0, 3))
 
    ' with assistance from Jon Peltier http://peltiertech.com/WordPress and 
    ' http://support.microsoft.com/kb/306022
 
    rngHeader.Value = Array("Subject", "Body", "Start Date", "Due Date")
 
    ColCount = rngHeader.Columns.Count
 
    ' now that we know how many rows and columns we need,
    ' resize the array accordingly
    ReDim arrData(1 To ItemstoCheck.Count, 1 To ColCount)
 
    For i = 1 To ItemstoCheck.Count
 
          Set ThisTask = ItemstoCheck.item(i)
 
            arrData(i, 1) = ThisTask.Subject
            arrData(i, 2) = ThisTask.Body
            arrData(i, 3) = Format(ThisTask.StartDate, "MM/DD/YYYY HH:MM AM/PM")
            arrData(i, 4) = Format(ThisTask.DueDate, "MM/DD/YYYY HH:MM AM/PM")
 
    Next i
 
    rngStart.Offset(1, 0).Resize(ItemstoCheck.Count, ColCount).Value = arrData
 
Else
    MsgBox "There are no tasks during the time you specified. Exiting now.", vbCritical
End If
 
ExitProc:
Set myTaskItems = Nothing
Set olNS = Nothing
Set olApp = Nothing
StringToCheck = vbNullString
Set ItemstoCheck = Nothing
Set MyBook = Nothing
Set rngStart = Nothing
Set rngHeader = Nothing
Set ThisTask = Nothing
Erase arrData
Application.ScreenUpdating = True
End Sub
1
2
3
4
Function Quote(MyText)
' from Sue Mosher's excellent book "Microsoft Outlook Programming"
    Quote = Chr(34) & MyText & Chr(34)
End Function

    Don’t forget to include the Quote UDF when copying this code.

    I used an array declared as Variant to store the data returned from Outlook. It’s a simple matter to determine the size of the array; since each row represents a separate task, the number of rows is going to be the number of tasks returned by the Restrict Method (ItemstoCheck.Count). The number of columns is even easier; we know how many fields we want to export, so it’s just a count of those fields. In the above example, we are exporting four fields, so a count of the number of columns will return the needed value.

    The ReDim statement is used here to re-size the array to make it exactly as large as needed.

    Everything is structured, variable-wise, so that we can easily add or remove columns without needing to re-work large parts of the code. The array size is automatically calculated based on the number of items found and the number of fields we want to export, so if you wanted to export more (or less), simply edit the string values in the Array() Function and add corresponding lines inside the For Loop for arrData to manage.

    To call the code above, simply pass two dates to it, as follows:

1
2
3
Sub GetTasks()
  Call GetTasksData("8/11/2008", "9/12/2008")
End Sub

    Here is the Outlook version, which is merely a slightly reworked version of the above code. This code also requires the Quote UDF, shown above. The OMG is so heinous that I recommend coding inside Outlook whenever possible, if you need to access anything protected from it (like email addresses). You can always instantiate Excel, Word, or Access from it and do what you need.

Outlook version:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
Sub GetTasksData(StartDate As Date, Optional EndDate As Date)
' -------------------------------------------------
' Notes:
' End Date is optional, if you want to pull from only one day, use: Call GetTasksData("7/14/2008")
' -------------------------------------------------
 
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim myTaskItems As Outlook.Items
Dim ItemstoCheck As Outlook.Items
Dim ThisTask As Outlook.TaskItem
 
Dim xlApp As Excel.Application
Dim rng As Excel.Range
Dim rngStart As Excel.Range
Dim rngHeader As Excel.Range
Dim MyBook As Excel.Workbook
 
Dim i As Long
Dim NextRow As Long
Dim ColCount As Long
 
Dim MyItem As Object
Dim StringToCheck As String
Dim arrData() As Variant
 
' if no end date is specified, EndDate variable will be "12:00:00 AM"
' the requestor only wants one day, so set EndDate = StartDate
If EndDate = "12:00:00 AM" Then
    EndDate = StartDate
End If
 
If EndDate < StartDate Then
    MsgBox "Those dates seem switched, please check them and try again.", vbInformation
    GoTo ExitProc
End If
 
If EndDate - StartDate > 28 Then
    ' ask if the requestor wants so much info
    If MsgBox("This could take some time. Continue anyway?", vbInformation + vbYesNo) = vbNo Then
        GoTo ExitProc
    End If
End If
 
Set olApp = Outlook.Application
 
' hook into default Tasks folder
Set olNS = olApp.GetNamespace("MAPI")
Set myTaskItems = olNS.GetDefaultFolder(olFolderTasks).Items
 
' ------------------------------------------------------------------
' the following code adapted from:
' http://www.outlookcode.com/article.aspx?id=30
' http://weblogs.asp.net/whaggard/archive/2007/03/21/retrieving-your-
' outlook-appointments-for-a-given-date-range.aspx
'
With myTaskItems
    .Sort "[StartDate]", False
    .IncludeRecurrences = True
End With
'
StringToCheck = "[StartDate] >= " & Quote(StartDate) & " AND [DueDate] <= " & Quote(EndDate)
Debug.Print StringToCheck
'
Set ItemstoCheck = myTaskItems.Restrict(StringToCheck)
Debug.Print ItemstoCheck.Count
' ------------------------------------------------------------------
 
If ItemstoCheck.Count > 0 Then
    ' we found at least one task
    ' check to make sure we have actual tasks, not infinite recurrence issues
    If ItemstoCheck.Item(1) Is Nothing Then GoTo ExitProc
 
    Set xlApp = Excel.Application
 
    xlApp.ScreenUpdating = False
 
    Set MyBook = xlApp.Workbooks.Add
 
    xlApp.Visible = True
 
    MyBook.Sheets(1).Name = Format(StartDate, "MMDDYYYY") & " - " & Format(EndDate, "MMDDYYYY")
    Set rngStart = MyBook.Sheets(1).Range("A1")
 
    Set rngHeader = Range(rngStart, rngStart.Offset(0, 3))
 
    ' with assistance from Jon Peltier http://peltiertech.com/WordPress and
    ' http://support.microsoft.com/kb/306022
 
    rngHeader.Value = Array("Subject", "Body", "Start Date", "Due Date")
 
    ColCount = rngHeader.Columns.Count
 
    ' now that we know how many rows and columns we need,
    ' resize the array accordingly
    ReDim arrData(1 To ItemstoCheck.Count, 1 To ColCount)
 
    For i = 1 To ItemstoCheck.Count
 
          Set ThisTask = ItemstoCheck.Item(i)
 
            arrData(i, 1) = ThisTask.Subject
            arrData(i, 2) = ThisTask.Body
            arrData(i, 3) = Format(ThisTask.StartDate, "MM/DD/YYYY HH:MM AM/PM")
            arrData(i, 4) = Format(ThisTask.DueDate, "MM/DD/YYYY HH:MM AM/PM")
 
    Next i
 
    rngStart.Offset(1, 0).Resize(ItemstoCheck.Count, ColCount).Value = arrData
 
    xlApp.ScreenUpdating = True
 
Else
    MsgBox "There are no tasks during the time you specified. Exiting now.", vbCritical
End If
 
 
ExitProc:
Set myTaskItems = Nothing
Set olNS = Nothing
Set olApp = Nothing
Set xlApp = Nothing
StringToCheck = vbNullString
Set ItemstoCheck = Nothing
Set MyBook = Nothing
Set rngStart = Nothing
Set rngHeader = Nothing
Set ThisTask = Nothing
Erase arrData
 
End Sub

    Note that the code above is early bound and requires a reference to the Excel library. The key changes are: We reference the Outlook Application Object directly, instead of using GetObject or CreateObject. We have to qualify Excel references with the Excel.Application object, xlApp, instead of “Application.” Otherwise it’s nearly identical, and avoids the OMG considerations.

Enjoy,
JP

Conditional Import Text Files

August 26, 2008 – 2:11 pm

    If you have a text file to import, but only need some of the data, you could just import the whole thing and then manually scrub the data to find what you want. Text files can contain a lot more lines than an Excel worksheet, but much of it may be fluff. Here’s a method for importing only the data you need.

    First I created a text file with some sample data, here’s a screenshot:

testfile1-247x300

    I realize it’s short, but it serves our purpose. Here is the import sub:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
Sub ConditionalImport()
Dim lNum As Long
Dim strLine As String
Dim lNextRow As Long
 
Application.ScreenUpdating = False
 
' get number of next free file
lNum = FreeFile
 
' open text file for input, loop through each line,
' only import rows we need
 
Open "C:\testfile.txt" For Input As #lNum
 
  Do While Not EOF(lNum)
    lNextRow = WorksheetFunction.CountA(Range("A:A"))
    Line Input #lNum, strLine
  '
  ' test "strLine" here
  '
  Loop
 
Close lNum
 
Application.ScreenUpdating = True
End Sub

    The part right after “Line Input #lNum, strLine” is the part you would customize. Each line of the text file is read into the string variable strLine. Now you can test to see if it is a number (IsNumeric), has a certain number of characters (Len), the way you would do with any other String to see if meets the criteria you want to specify.

    For example, if I only wanted to import the data rows that start with “ABC”, I would use this:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
Sub ConditionalImport()
Dim lNum As Long
Dim strLine As String
Dim lNextRow As Long
 
Application.ScreenUpdating = False
 
' get number of next free file
lNum = FreeFile
 
' open text file for input, loop through each line,
' only import rows we need
 
Open "C:\testfile.txt" For Input As #lNum
 
  Do While Not EOF(lNum)
    lNextRow = WorksheetFunction.CountA(Range("A:A"))
    Line Input #lNum, strLine
 
    If (Left$(strLine, 3) = "ABC") Then
      Cells(lNextRow + 1, 1).Value = strLine
    End If
 
  Loop
 
Close lNum
 
Application.ScreenUpdating = True
End Sub

Enjoy,
JP

Check Your Premises

August 26, 2008 – 12:47 pm

    When you are using early bound code for your own personal applications, it’s easy to ensure that the proper object libraries are referenced: Simply go to Tools > References and check off the libraries you need. Then you can code using fully qualified references like “Excel.Range” and “Outlook.Application”.

    If you are writing code for others, however, there’s no guarantee that the libraries will be referenced or even installed. For example, if your code uses ADO to utilize an Access database, your code needs to check if ADO is referenced and available before making any attempt to use ADO code.

    I’ve written previously about version checking (see Make your Office add-in version-independent); here are some sample subs that can make it happen. This first sub will list the references from the current workbook directly onto the worksheet, so you can see the names of each project. I saw this code somewhere else, I think it was Colo’s Excel Junk Room, but I wasn’t able to find a link, so I rolled my own. The Name Property is what we’re most concerned with; it’s how we are going to identify references later on in the “live” code.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
Sub ListProjectReferences()
Dim NextRow As Long
Dim NextCol As Long
Dim lCount As Long
Dim objRef As VBIDE.Reference
Dim rng As Excel.Range
 
Set rng = Range("A1")
 
NextRow = 0
NextCol = 1
 
With Application.VBE.ActiveVBProject.References
  For lCount = 1 To .Count
    Set objRef = .item(lCount)
 
    Debug.Print objRef.Name & " " & objRef.FullPath
    Cells(NextRow + 1, NextCol).Value = objRef.Name
    Cells(NextRow + 1, NextCol + 1).Value = objRef.FullPath
 
    NextRow = NextRow + 1
 
  Next lCount
End With
 
ExitProc:
Set rng = Nothing
Set objRef = Nothing
End Sub

    The above code requires a reference to the Microsoft Visual Basic for Applications Extensibility library. As an alternative, you can change “Dim objRef As VBIDE.Reference” to “Dim objRef As Object” and it will work without the reference. The name and path of each currently referenced object library is written to the worksheet, starting in cell A1. Go ahead and test this out by setting a few references to other libraries and re-running the code to see the Name and the full path.

    Now that you have the names of each reference, you can loop through the collection quickly to see if the appropriate libraries needed for your application are already referenced. Then you can either move on to the purpose of the code, or create the object library references if they didn’t already exist.

    For example, if we needed a reference to Outlook and DAO for our application, we run the code above and learn that, if referenced, the names are “Outlook” and “DAO” respectively, for each object library. Here’s some startup code that would check if they are already referenced. We loop through the references and check the name, and if it matches, we use two Boolean variables to store the result.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
Private Sub Workbook_Open()
Dim lCount As Long
Dim strRefName As String
Dim bIsOutlookLibReferencedAtStartup As Boolean
Dim bIsDAOLibReferencedAtStartup As Boolean
' check if each needed object library is already referenced
With Application.VBE.ActiveVBProject.References
  For lCount = 1 To .Count
    strRefName = .item(lCount).Name
    If strRefName = "Outlook" Then
      bIsOutlookLibReferencedAtStartup = True
    ElseIf strRefName = "DAO" Then
      bIsDAOLibReferencedAtStartup = True
    End If
  Next lCount
End With
End Sub

    If our Boolean variable is False, then the needed reference doesn’t already exist, so we need to add it. We’ll continue with Outlook only. We’ll use a separate single-purpose sub called AddVBRef (below) and pass the reference name we want to add as an argument. If successful, we use another boolean variable to remember that we referenced Outlook, so we can de-reference it later.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
Dim bWeStartedOutlook As Boolean
If Not bIsOutlookLibReferencedAtStartup Then
  ' Outlook was not already referenced when we started
  If Not AddVBRef("Outlook") Then
    MsgBox "This add-in requires a reference to Outlook object library." & _
         " Please make sure that Outlook is installed on your" & _
    "computer and that you can set a reference to it manually.", vbCritical
    ThisWorkbook.Close False
    Exit Sub
  Else
    ' we were able to successfully reference Outlook
    bWeStartedOutlook = True
  End If
End If
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
Private Function AddVBRef(strRefName As String) As Boolean
' short sub that takes argument and adds references whatever 
' reference is passed to it, returns True/False to calling sub
AddVBRef = False
Dim OutlookStartFolder As String
 
With Application.VBE.ActiveVBProject.References
  Select Case strRefName
    Case "Outlook"
      OutlookStartFolder = OFCStartFolder("Outlook")
      Select Case Application.Version
        Case Is &lt; 10 ' Office 2000
          On Error Resume Next
          .AddFromFile OutlookStartFolder & "\msoutl9.olb"
          On Error GoTo 0
          If Err = 0 Then AddVBRef = True
          Exit Function
        Case Is &gt;= 10 ' Office 2002-2007
          On Error Resume Next
          .AddFromFile OutlookStartFolder & "\msoutl.olb"
          On Error GoTo 0
          If Err = 0 Then AddVBRef = True
          Exit Function
      End Select
    End Select
End With
End Function

    Right now AddVBRef only adds a reference to Outlook; you would add additional Case statements, using the Name you want to add. Also keep in mind that it only works for Office programs; the function calls another function, OFCStartFolder which returns the install path for whatever Office program you pass to it:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
Function OFCStartFolder(strProgram As String, Optional lVersion As Long) As String
' from Jon Peltier, slightly modded by Jimmy Pena 8-11-08
'
' strProgram can be "Excel", "Word", "Access", "PowerPoint", "Outlook", "Publisher"
' lVersion can be 2007, 2003, 2003, 2000 - if blank, it looks for highest version available
'
Dim wsh As Object
Dim i As Integer
Dim sReg As String
Dim lVerNum As Long
 
If lVersion <> 0 Then
' We are looking for a specific version's install folder, i.e. if someone has multiple versions
' and we want to hook a specific version.
' However, the point of an add-in is that we don't know what version the end user has, so
' this part of the IF loop should rarely be used.
 
  Select Case lVersion
    Case 2007
      lVerNum = 12
    Case 2003
      lVerNum = 11
    Case 2002
      lVerNum = 10
    Case 2000
      lVerNum = 9
    Case Else
      MsgBox "Please specify a valid version."
      GoTo ExitProc
  End Select
 
  sReg = "HKLM\SOFTWARE\Microsoft\Office\" & lVerNum & ".0\" & strProgram & "\InstallRoot\Path"
  Set wsh = CreateObject("Wscript.Shell")
 
  On Error Resume Next
  OFCStartFolder = wsh.RegRead(sReg)
  On Error GoTo 0
Else
' no version was specified, just find highest version
  Set wsh = CreateObject("Wscript.Shell")
 
  For i = 12 To 9 Step -1   ' (12 = 2007, 11 = 2003, 10 = 2002, 9 = 2000)
    sReg = "HKLM\SOFTWARE\Microsoft\Office\" & CStr(i) & ".0\" & strProgram & "\InstallRoot\Path"
 
    On Error Resume Next
    OFCStartFolder = wsh.RegRead(sReg)
    On Error GoTo 0
 
    If Len(OFCStartFolder) > 0 Then Exit For
  Next i
End If

    And here is a companion sub that removes any reference passed to it. Again we are passing the Name Property here. We’ll need this in case we referenced the object library, we must clean up after ourselves and remove that reference if our code is removed or uninstalled.

1
2
3
4
5
6
7
8
9
10
11
12
13
Private Function RemoveVBRef(strRefName As String)
' short sub that takes argument and de-references
' whatever reference is passed to it
Dim lCount As Long
With Application.VBE.ActiveVBProject.References
  For lCount = 1 To .Count
    If .item(lCount).Name = strRefName Then
      .Remove .item(lCount)
      Exit Function
    End If
  Next i
End With
End Function

    Which would be used as follows in our shutdown code:

1
If bWeStartedOutlook Then RemoveVBRef ("Outlook")

    Remember, bWeStartedOutlook would only be true if we manually set a reference to Outlook with the AddVBRef function, which itself would only be run if Outlook wasn’t already referenced at startup.

    One thing I should also mention is that the purpose of much of the code above is to check if we can use early bound code. If you are going to use late-bound code, you won’t need much of it (just a check of the install path to see if the program is installed before we can reference any of its objects).

Oh and if anyone was interested, here is the computer I ended up buying: Gateway

Enjoy,
JP

Forget about it!

August 25, 2008 – 9:57 pm

    After much deliberation, I’ve decided to stop working on the Excel add-in I was creating to export Contacts, Tasks and Appointments to Excel. I haven’t been spending enough time working on it, and rather than continuing to procrastinate, I’ve decided to just release the source code and let others pick up the development.

    Turns out, accessing the Outlook object model is harder than it looks, and several key elements (email addresses, MeetingItem .Body Property) are protected by the Object Model Guard (OMG). This Outlook “feature” requires third-party object libraries like Redemption, which has a low learning curve, but a few strikes against it:

  • Most non-developers (aka you and me) don’t have it, so it requires separate install and check routines over and above the existing VBA, to make sure it would work on a remote PC.
  • Redemption can’t be distributed, since it is commercial software and wouldn’t be protected by Excel/VBA.
  • Redemption costs $199, and I’m not prepared to buy it for something I could still do manually, or in VBA if I’m willing (perfectly) to live with the security prompt.

    So the next few posts will contain bits of the mostly finished code, and if anyone wants to download the whole xla “as is”, let me know and I will send you a copy.

ps- If anyone was wondering, I usually use ClickYes to get around the security prompt if I am doing something like a mail merge to email. Then you can go get coffee while your computer is working hard ;) Seriously, download it before the free version goes pay.

Thx,
JP

Add your signature to pre-formatted emails

August 25, 2008 – 3:46 pm

    Ever wanted to have an army of pre-formatted emails, which you can send at the click of a button, but couldn’t figure out how to programmatically insert your signature at the end? Here’s one method that should work for you.

    First you should make a note of whether your signature is appended automatically to new emails. If you’re not sure, start Outlook and go to Tools > Options > Mail Format and check the ‘Signature for new messages’ box. If you have a named signature there, then your chosen signature is being added to every new message you originate.

signaturefornew-253x300

    Here is your sample code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
Sub StockMsgWithSignatureVersion1()
 
Dim NewMsg As Outlook.MailItem
 
Set NewMsg = CreateItem(olMailItem)
 
NewMsg.Display
 
With NewMsg
  .Subject = "Here's my subject"
  .HTMLBody = "<p>Hello,</p>" & _
    "<p>Here's my daily stats report: </p>" & _
  "<p>Number of emails I ignored: <br />" & _
  "Meetings missed: <br />" & _
  "Files deleted by mistake: <br />" & _
  "Presentations not upated: </p>" & .HTMLBody
End With
 
Set NewMsg = Nothing
End Sub

    Very simply, we create a new mail message and update the body with our chosen text, moving the signature below the added text. Keep in mind this is the HTMLBody property, so we don’t use vbCr or vbCrLf when we want a new line; we have to use HTML tags like <br /> and <p> to format the email body.

    We can get more complicated with this. We can add arguments to the sub, which are then called from another sub which can be assigned to a toolbar button. For example:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
Sub StockMsgWithSignatureVersion2(strSubject As String, Ignored As Long, _
Missed As Long, Files As Long, Pres As Long)
 
Dim NewMsg As Outlook.MailItem
 
Set NewMsg = CreateItem(olMailItem)
 
NewMsg.Display
 
With NewMsg
  .Subject = strSubject
  .HTMLBody = "<p>Hello,</p>" & _
    "<p>Here's my daily stats report: </p>" & _
  "<p>Number of emails I ignored: " & Ignored & "<br />" & _
  "Meetings missed: " & Missed & "<br />" & _
  "Files deleted by mistake: " & Files & "<br />" & _
  "Presentations not upated: " & Pres & "</p>" & .HTMLBody
End With
 
Set NewMsg = Nothing
End Sub
1
2
3
Sub CallMySub()
  Call StockMsgWithSignatureVersion2("Hey now!", 30, 3, 5, 8)
End Sub

    The sub CallMySub would be added to a toolbar button (see Resend This Message for instructions). Just create several copies of it, with different parameters, and give each toolbar button a different name.

    But what about if your signature is not being inserted automatically? Here is the code you should use:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
Sub StockMsgWithSignatureVersion3()
 
Dim NewMsg As Outlook.MailItem
Dim objInsp As Outlook.Inspector
Dim cbc As Office.CommandBarPopup
Dim cbControls As Office.CommandBarControls
Dim cbButton As Office.CommandBarButton
 
Set NewMsg = CreateItem(olMailItem)
 
NewMsg.Display
 
Set objInsp = ActiveInspector
If Not objInsp Is Nothing Then
  Set cbc = objInsp.CommandBars.FindControl(, 31145)
End If
 
If Not cbc Is Nothing Then
  Set cbControls = cbc.Controls
End If
 
For Each cbButton In cbControls
    If cbButton.Caption = "Signature" Then
        cbButton.Execute
        Exit For
    End If
Next
 
With NewMsg
  .Subject = "Here's my subject"
  .HTMLBody = "<p>Hello,</p>" & _
    "<p>Here's my daily stats report: </p>" & _
  "<p>Number of emails I ignored: <br />" & _
  "Meetings missed: <br />" & _
  "Files deleted by mistake: <br />" & _
  "Presentations not upated: </p>" & .HTMLBody
End With
 
ExitProc:
Set cbControls = Nothing
Set cbc = Nothing
Set objInsp = Nothing
Set NewMsg = Nothing
End Sub

    The above code sets an object reference to the Insert|Signature command on the toolbar (using the FindControl ID) and loops through all the buttons on the submenu until it finds one with the name “Signature” (which is the name of the signature we want to use). Otherwise it’s exactly the same as the code at the top of the post. Make sure to substitute the name of the signature you want to use.

Enjoy,
JP

Processing multiple emails

August 25, 2008 – 1:23 pm

    In Highlight And Move Multiple Emails, I demonstrated a technique for processing several emails at once and moving them to another folder. Here is another example that shows how you can save attachments from several selected emails, then delete them.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
Sub SaveEmailAttachments()
 
Dim Msg As Outlook.MailItem
Dim MsgColl As Object
Dim MsgAttach As Outlook.Attachments
Dim i As Long
Dim FileN As String
Dim lAttach As Long
 
On Error Resume Next
Set MsgColl = ActiveExplorer.Selection
On Error GoTo 0
 
If Not MsgColl Is Nothing Then
  For i = 1 To MsgColl.Count
 
    ' loop through selected items and save all attachments from each of them
    Set Msg = MsgColl.Item(i)
    Set MsgAttach = Msg.Attachments
 
    For lAttach = 1 To MsgAttach.Count
      FileN = MsgAttach.Item(lAttach).DisplayName
      MsgAttach.Item(lAttach).SaveAsFile "C:\My Folder\" & FileN
    Next lAttach
 
  Next i
 
    If MsgBox("Would you like to delete the selected emails now?", _
     vbInformation + vbYesNo) = vbYes Then
        For i = 1 To MsgColl.Count
          Set Msg = MsgColl.Item(i)
          Msg.Delete
        Next i
    End If
Else
  GoTo ExitProc
End If
 
ExitProc:
Set MsgAttach = Nothing
Set Msg = Nothing
Set MsgColl = Nothing
End Sub

    Other things you can do involve incorporating other email properties, such as received time. This will save the filename with date and time pre-pended to the display name:

1
MsgAttach.Item(lAttach).SaveAsFile "C:\My Folder\" & Format(Msg.ReceivedTime, "mmddyyyy hhmm") & " " & FileN

    And this will save the filename as just the received time, with the proper file extension:

1
MsgAttach.Item(lAttach).SaveAsFile "C:\My Folder\" & Format(Msg.ReceivedTime, "mmddyyyy hhmm") & Right$(FileN, 4)

    You can also use the Subject property:

1
MsgAttach.Item(lAttach).SaveAsFile "C:\My Folder\" & Msg.Subject & " " & Format(Msg.ReceivedTime, "mmddyyyy hhmm") & Right$(FileN, 4)

    This will set the attachment filename to Subject and Received time.

Enjoy,
JP

Excel, I choose you!

August 22, 2008 – 3:38 pm

    My son and his friends are really into Pokemon. After the initial disgust wore off, I noticed that the characters are all catalogued and classed into different categories, with different levels, strengths and abilities, so I went and found this cool color chart showing the effectiveness of different attacks on different Pokemon types. What better way to make use of Excel than a few charts showing how different Pokemon fare against each other? Ok, I’m sure there are better ways to use Excel, but I was bored. Hopefully I won’t get a C&D from Nintendo for this post.

    I couldn’t find anything similar to the effectiveness chart in Excel, so I created my own. Here’s a screenshot.

sp32-20080820-165559-300x84

  • N = Low damage
  • \/ = Normal damage
  • Y = High damage
  • X = Immune

    The chart lets you visually cross-reference the attack type with the Pokemon type. So now you can see that a Fight attack is highly effective against Rock Pokemon, but Ghost Pokemon are immune to it. I’m sure you are so excited at this point!!

    But how to turn this into a useful chart? We need to turn the data from a grid into a column-based table with field names at the top. Each attack is pitted against its own type, and every other type, and there are 17 types. Therefore we list each type 17 times in the same column, and then list every other type next to it, along with the effectiveness.

sp32-20080822-140105-116x300

    You can see above how the first three attacks are listed, with the Pokemon type list simply duplicated in the middle column repeatedly. I just cut-and-pasted the row and transposed it (using Paste Special) into the column; I did the same for the effectiveness column.

(Special thanks to Excel MVP Jon Peltier for informing me of the proper way to do this.)

    In case you were wondering, this is how you can turn any “grid” type data into something usable for a PivotTable.

    Now we can create some meaningful PivotTables to let our Pokemon battle! The first one shows the effectiveness of each attack against each Pokemon type. I select the data and then run the PT wizard to create a blank PivotTable. You should end up with something similar to the picture below.

sp32-20080822-145302-300x155

    Click and drag ‘Type’ to the Page field area and drag ‘Attack’ to the Row field area. Drag ‘Effectiveness’ to both the Column field and Data field area (i.e. two times). You should end up with this:

sp32-20080822-145859-277x300

    Click the dropdown arrow in the cell next to ‘Type’ to select various Pokemon types. Then you can see how effective each attack is against that type. Next we’ll move on to the other type of PivotTable we can create: one that shows how each type of attack fares against each Pokemon type.

    I’ll highlight the same data from the previous PT, and run the wizard again. At the end of the wizard, Excel will notice that we selected the exact same data and ask if we want to use the same pivot cache for the new PT. I’ll click ‘Yes’, but it really doesn’t matter, since we’re only creating two PivotTables. However, if you are creating several automated tables or charts at once, it is more memory efficient to use the same cache to make them all, especially if they all use the same data source or if the data is external to Excel (i.e. Access, SQL).

    The PT will be exactly the same, except we swap the Attack and Type fields; the Attack field goes in the Page field area, and the Type field goes in the Row field area. Now you can select an attack type and see how it affects each Pokemon type.

sp32-20080822-151049-300x253

    Download a sample workbook containing all of the charts and PivotTables.

Enjoy,
JP