Invoke Outlook Contacts From Within Excel

[Cole]

Hi folks,

I don't do much with VBA, so any explicit help is greatly appreciated.

I'm trying to push a button in Excel and have it:

See if Outlook is already started. If not - start it up.
Change focus to the Outlook Contacts page.

I've looked at several postings in this group and tried some stuff, but

nothing seems to work, thus far. Here is what I tried (Commented out
cause it didn't work.) So feel free to ignore the code snippits I've
found. (I could also use a suggestion on a really good book on
programming in VB and/or VBA for a programmer coming from a totally
different paradigm.)

'Dim IsItRunning As Boolean

' On Error Resume Next
' whichprogram = GetObject(, "Outlook.Application")
' If whichprogram = "Outlook" Then IsItRunning = True Else
IsItRunning = False ' <== This stmt did not work.
' Err.Clear
' If WhichProgram = "Outlook" Then IsItRunning = True
' If IsItRunning = False Then
' Dim RetVal
' RetVal = Shell("C:\Program Files\Microsoft
Office\Office11\Outlook.EXE", 6)
' End If


AND I TRIED THE FOLLOWING:


' Dim objOutlook As Object
' Dim objPhonelist As Object
' Dim olNameSpace As Object


'''Set the reference to the Outlook object model
' On Error Resume Next
' ThisWorkbook.VBProject.References.AddFromFile Application.Path & _

' "\00SVO\Company Directory\Company Phone Numbers"
' On Error GoTo 0


'''Create the Outlook object
' Set objOutlook = CreateObject("Outlook.Application")


'''Get Outlook's work area
' Set olNameSpace = objOutlook.GetNamespace("MAPI")


'''Access and display the default Inbox folder
' Set objPhonelist = olNameSpace.GetDefaultFolder(objPhonelist)
' objInbox.Display


Thank you in advance for your help.


Kind regards,
Cole

 

[Michael]

Not sure if this helps but I have some code to Import Contacts from Outlook
to an Excel list. Works fine for me. This code shows how to start Oulook
from Excel at least.

-- Michalakis Michael (Cyprus)

Public Sub SaveContactsToExcel()
'Demonstrates pushing Contact data to an Excel List

On Error GoTo ErrorHandler

Dim appWord As Word.Application
Dim appExcel As Excel.Application
Dim appOutlook As Outlook.Application
Dim wkb As Excel.Workbook
Dim wks As Excel.Worksheet
Dim rng As Excel.Range
Dim strSheet As String
Dim strTemplatePath As String
Dim i As Integer
Dim j As Integer
Dim lngCount As Long
Dim nms As Outlook.Namespace
Dim fld As Outlook.MAPIFolder
'Must declare as Object because folders may contain different types of
items
Dim itm As Object
Dim strTitle As String
Dim strPrompt As String

Set appWord = GetObject(, "Word.Application")
Set appExcel = GetObject(, "Excel.Application")
Set wkb = appExcel.ActiveWorkbook
Set wks = wkb.Sheets(1)
wks.Activate
appExcel.Application.Visible = True

'Added by Mmichael
Dim List1 As ListObject
Set List1 = wks.ListObjects(1)

'Let user select a folder to export
Set appOutlook = GetObject(, "Outlook.Application")
Set nms = appOutlook.GetNamespace("MAPI")
Set fld = nms.PickFolder
If fld Is Nothing Then
GoTo ErrorHandlerExit
End If

'Test whether selected folder contains contact items
If fld.DefaultItemType <> olContactItem Then
MsgBox "Folder does not contain contacts"
GoTo ErrorHandlerExit
End If

lngCount = fld.Items.Count

If lngCount = 0 Then
MsgBox "No Contacts to export"
GoTo ErrorHandlerExit
Else
Debug.Print lngCount & " Contacts to export"
End If

'Adjust i (row number) to be 1 less than the number of the first body row
i = 3

'Iterate through contact items in Contacts folder, and export a few fields
'from each item to a row in the Contacts worksheet
For Each itm In fld.Items
If itm.Class = olContact Then
'Process item only if it is a contact item
i = List1.DataBodyRange.Rows.Count + 11

'j is the column number
j = 2

'Add the First Name
Set rng = wks.Cells(i, j)
If itm.FirstName <> "" Then rng.Value = itm.FirstName
j = j + 1

'Add the Last Name
Set rng = wks.Cells(i, j)
If itm.LastName <> "" Then rng.Value = itm.LastName
j = j + 1

'Add the E-mail
Set rng = wks.Cells(i, j)
If itm.Email1DisplayName <> "" Then rng.Value =
itm.Email1DisplayName
j = j + 1

'Add the HomeTelephoneNumber
Set rng = wks.Cells(i, j)
If itm.HomeTelephoneNumber <> "" Then rng.Value =
itm.HomeTelephoneNumber
j = j + 1

'Add the BusinessTelephoneNumber
Set rng = wks.Cells(i, j)
If itm.BusinessTelephoneNumber <> "" Then rng.Value =
itm.BusinessTelephoneNumber
j = j + 2

'Cell Telephone Number is a placeholder

'Add the BusinessFaxNumber
Set rng = wks.Cells(i, j)
If itm.BusinessFaxNumber <> "" Then rng.Value =
itm.BusinessFaxNumber
j = j + 2

' BirthDate is a placeholder

'Add the HomeAddress
Set rng = wks.Cells(i, j)
If itm.HomeAddress <> "" Then rng.Value = itm.HomeAddress
j = j + 1

'Add the HomeAddressCity
Set rng = wks.Cells(i, j)
If itm.HomeAddressCity <> "" Then rng.Value = itm.HomeAddressCity
j = j + 1

'Add the HomeAddressState
Set rng = wks.Cells(i, j)
If itm.HomeAddressState <> "" Then rng.Value = itm.HomeAddressState
j = j + 1

'Add the HomeAddressCountry
Set rng = wks.Cells(i, j)
If itm.HomeAddressCountry <> "" Then rng.Value =
itm.HomeAddressCountry
j = j + 1

'Add the CompanyName
Set rng = wks.Cells(i, j)
If itm.CompanyName <> "" Then rng.Value = itm.CompanyName
j = j + 1

'Add the WebPage
Set rng = wks.Cells(i, j)
If itm.WebPage <> "" Then rng.Value = itm.WebPage
j = j + 1

Set rng = wks.Cells(i, j)
On Error Resume Next
'The next line illustrates the syntax for referencing
'a custom Outlook field
If itm.UserProperties("CustomField") <> "" Then
rng.Value = itm.UserProperties("CustomField")
End If
j = j + 1

End If
i = i + 1
Next itm

ErrorHandlerExit:
Exit Sub

ErrorHandler:
If Err.Number = 429 Then
'Application object is not set by GetObject; use CreateObject instead
If appOutlook Is Nothing Then
Set appOutlook = CreateObject("Outlook.Application")
Resume Next
ElseIf appWord Is Nothing Then
Set appWord = CreateObject("Word.Application")
Resume Next
ElseIf appExcel Is Nothing Then
Set appExcel = CreateObject("Excel.Application")
Resume Next
End If
Else
MsgBox "Error No: " & Err.Number & "; Description: "
Resume ErrorHandlerExit
End If

End Sub