Adding Contact with VBA

  • Thread starter Thread starter Greg Maxey
  • Start date Start date
G

Greg Maxey

Hi,

I am using the following code to add a contact to OUTLOOK while working in
Word:

Sub myBtnMacro
Dim oApp As Outlook.Application
Dim oNspc As NameSpace
Dim oItm As ContactItem
Dim i As Long
Dim pStr As String
Set oApp = CreateObject("Outlook.Application")
Set oNspc = oApp.GetNamespace("MAPI")
Set oItm = oApp.CreateItem(olContactItem)
pStr = Selection.Text
pStr = Replace(pStr, Chr(13), Chr(11))
With oItm
.MailingAddress = Selection.Text
.Display
End With
Set oApp = Nothing
Set oNspc = Nothing
End Sub

The user selects the address portion of the text, runs the macro and the
OUTLOOK Create Contact dialog appears. The user types in any additional
information and Saves and Closes the Contact dialog.

My results are very sporadic and confusing. Sometimes the contact appears
in OUTLOOK contacts as soon as I finish adding it with Word and opening
OUTLOOK. Other times the contact doesn't apppear for several minutes and
after repeated tries to open and look for it in OUTLOOK. This morning I
tried to add two contacts. After several tries they never appeared in
OUTLOOK. I shut down my PC and restarted and tried to add another contact.
When I opened OUTLOOK none of the three contacts I had tried to add where
present. Then all of a sudden I hear bing, bing and the two previous
contacts appeared but never the third.

Obviously my code has a shortcoming. Can anyone please advise. Thanks.


--
~~~~~~~~~~~~~~~~~~~~~~~~~~~
Greg Maxey - Word MVP

My web site http://gregmaxey.mvps.org

~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
Sue,

Thanks. That seems to have solved the issue. It took me a while to figure
out that I was supposed to use "OUTLOOK" in place of "ProfileName"

Here is what I have now that is working as I expected:

Sub myBtnMacro(ByVal control As IRibbonControl)
Dim oApp As Outlook.Application
Dim oItm As ContactItem
Dim pStr As String
On Error Resume Next
Set oApp = GetObject(, "Outlook.Application")
If oApp Is Nothing Then
Set oApp = CreateObject("Outlook.Application")
oApp.Session.Logon "Outlook", , True, True
End If
Set oItm = oApp.CreateItem(olContactItem)
pStr = Selection.Text
With oItm
.MailingAddress = pStr
.Display
End With
Set oApp = Nothing
End Sub

I would like to ask another question related to this code and OUTLOOK.

When the code runs the new contact item dialog opens and the text selected
in Word is shown in the "Address" field exactly as it appears in the Word
document (i.e, two or three lines of text). However, in the business card
view all of the text is one running line with a "box" delimiter. I have
tried using both a Word paragraph and line break but both result in the same
thing. If I click in the address field and remove the "paragraph" and
re-enter while in OUTLOOK the business card view then appears as normal.

Do you know how this could be resolved programatically?

Thanks.

--
~~~~~~~~~~~~~~~~~~~~~~~~~~~
Greg Maxey - Word MVP

My web site http://gregmaxey.mvps.org

~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
If you look at the data that Outlook actually is storing, you should see that the "good" address has a vbCrLf for a delimiter between lines, while the "bad" one has only a vbCr. So, I think what you'll need to do is something like this:

If Instr(pStr, vbCrLf) = 0 Then
Replace(pStr, vbCr, vbCrLf)
End If
Itm.MailingAddress = pStr
 
Sue,

Thanks.

This is what I used:

If InStr(pStr, Chr(11)) > 1 Or InStr(pStr, vbCr) > 1 Then
pStr = Replace(pStr, vbCr, vbCrLf)
pStr = Replace(pStr, Chr(11), vbCrLf)
End If


--
~~~~~~~~~~~~~~~~~~~~~~~~~~~
Greg Maxey - Word MVP

My web site http://gregmaxey.mvps.org

~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
Back
Top