Create an outlook contact from Excel via VB

[mnmhenry]

I'm sure we all type this stuff TWICE. Enter details into excel and a month later when the job goes ahead, same data goes into Outlook Contacts.

I have the typical A1 "name", A2 "address", A3 "phone" list in excel and I would like to run some VB and put it into an Outlook contact.

I can find lots of code but nothing for outlook 2007 & Excel 2007

This is what I hove fount and is similar to what I am wanting but 2007 seems to be different with its reference to Outlook.



Sub Create_Outlook_Contact() ' Macro by Eliott Robson

Dim outlookApp As Outlook.Application
Dim outlookNameSpace As Outlook.Namespace
Dim outlookFolder As Outlook.Folders
Dim outookContact As Outlook.ContactItem
Dim ContactName As String
Dim ContactAddress As String
Dim ContactHomePhoneNumber As String
Dim ContactEmail As String

Set outlookApp = New Outlook.Application
Set outlookNameSpace = outlookApp.GetNamespace("MAPI")
Set outookContact = outlookApp.CreateItem(olContactItem)

ContactName = Cells(1, "B").Value
ContactAddress = Cells(2, "B").Value
ContactHomePhoneNumber = Cells(3, "B").Value
ContactEmail = Cells(4, "B").Value

With outookContact
.FullName = ContactName
.HomeAddress = ContactAddress
.HomeTelephoneNumber = ContactHomePhoneNumber
.Email1Address = ContactEmail
.JobTitle = ContactEmail
End With

outookContact.Save
MsgBox "Contact exported."

Many thanks.

 

[s.ridd]

Your code below works fine. You need to set a reference to the Microsoft Outlook 12.0 Object Library via Tools>References within the VBE.

Sub Create_Outlook_Contact() ' Macro by Eliott Robson

Dim outlookApp As Outlook.Application
Dim outlookNameSpace As Outlook.Namespace
Dim outlookFolder As Outlook.Folders
Dim outookContact As Outlook.ContactItem
Dim ContactName As String
Dim ContactAddress As String
Dim ContactHomePhoneNumber As String
Dim ContactEmail As String


Set outlookApp = New Outlook.Application
Set outlookNameSpace = outlookApp.GetNamespace("MAPI")
Set outookContact = outlookApp.CreateItem(olContactItem)


ContactName = Cells(1, "B").Value
ContactAddress = Cells(2, "B").Value
ContactHomePhoneNumber = Cells(3, "B").Value
ContactEmail = Cells(4, "B").Value


With outookContact
    .FullName = ContactName
    .HomeAddress = ContactAddress
    .HomeTelephoneNumber = ContactHomePhoneNumber
    .Email1Address = ContactEmail
    .JobTitle = ContactEmail
    .Save
End With


MsgBox "Contact exported."


End Sub

Otherwise you could try something like this

Sub Create_Outlook_Contact() ' Macro by Eliott Robson

Dim outlookApp As Object
Dim outlookNameSpace As Object
Dim outlookFolder As Object
Dim outookContact As Object
Dim ContactName As String
Dim ContactAddress As String
Dim ContactHomePhoneNumber As String
Dim ContactEmail As String


Set outlookApp = CreateObject("Outlook.Application")
Set outlookNameSpace = outlookApp.GetNamespace("MAPI")
outlookNameSpace.GetDefaultFolder(10).Display 'Contact won't appear without this line of code
Set outookContact = outlookApp.CreateItem(2)


ContactName = Cells(1, "B").Value
ContactAddress = Cells(2, "B").Value
ContactHomePhoneNumber = Cells(3, "B").Value
ContactEmail = Cells(4, "B").Value


With outookContact
    .FullName = ContactName
    .HomeAddress = ContactAddress
    .HomeTelephoneNumber = ContactHomePhoneNumber
    .Email1Address = ContactEmail
    .JobTitle = ContactEmail
    .Save
End With


outlookApp.Quit 'close Outlook again


MsgBox "Contact exported."


End Sub

Simon

 

[mnmhenry]

Thanks Simon that's a great help. The only other item I am fighting with is I'm wanting to export the active row where as the code below is selecting individual cells.

ContactName = Cells(8, "A").Value
ContactAddress = Cells(8, "B").Value
ContactHomePhoneNumber = Cells(8, "C").Value
ContactEmail = Cells(8, "D").Value

 

[mnmhenry]

I was able to work out what I needed.

ContactName = Cells(Application.ActiveCell.Row, 1).Value
ContactAddress = Cells(Application.ActiveCell.Row, 2).Value
ContactHomePhoneNumber = Cells(Application.ActiveCell.Row, 3).Value
ContactEmail = Cells(Application.ActiveCell.Row, 4).Value

Thanks for your help.