xjetjockey
01-09-2009, 05:52 PM
I have a program that runs from Excel. It creates an Outlook contact. I have another program that runs from Excel which retrieves Outlook contact data. For some reason the retrieval process doesn't find the Outlook contacts that I created from the Excel program, even though the contact is right there in Outlook! What's up with that? Any ideas? Here is my code to create the Outlook contact:
Sub MakeContact()
'Makes a new Outlook contact from the Prospect Data on "Main" sheet
Dim olApp As Outlook.Application
Dim olCi As Outlook.ContactItem
Dim PText As String
Dim PropText As String
Dim NotesText As String
Set olApp = New Outlook.Application
Set olCi = olApp.CreateItem(olContactItem)
NotesText = VBA.Date & " Proposal History Information" & vbNewLine & vbNewLine
PText = ""
PropText = MsgBox("Do you want to include the current proposal text in your Outlook notes section?" _
& vbNewLine & "This action will retrieve the body text of the currently prpared proposal." _
& vbNewLine & "Click Cancel if you need to prepare the proposal.", vbYesNoCancel + vbQuestion, "Include Proposal Text?")
If PropText = vbYes Then
PText = Sheet15.Range("A17").Value
NotesText = NotesText & "Proposal Text" & vbNewLine & PText & vbNewLine & vbNewLine
End If
If PropText = vbCancel Then
Exit Sub
End If
With olCi
.FirstName = Sheets("Main").tbFIRSTNAME.Value
.Body = "Contact Added " & VBA.Date & vbNewLine & vbNewLine & NotesText & vbNewLine & vbNewLine
'CODE GOES HERE TO COPY AND PASTE A RANGE OF CELLS FROM WORKSHEET TO CONTACT NOTES SECTION?
'APPEND TO EXISTING NOTES
.COMPANYNAME = Sheets("Main").tbCOMPANYNAME.Value
.LastName = Sheets("Main").tbLASTNAME.Value
.BusinessTelephoneNumber = Sheets("Main").tbPHONE.Value
.BusinessFaxNumber = Sheets("Main").tbFAX.Value
.Email1Address = Sheets("Main").tbCONTACTEMAIL.Value
.BusinessAddressCity = Sheets("Main").tbCITY.Value
.BusinessAddressStreet = Sheets("Main").tbADDRESS.Value
.BusinessAddressState = Sheets("Main").tbSTATE.Value
.BusinessAddressPostalCode = Sheets("Main").tbZIP.Value
.SelectedMailingAddress = olBusiness
.Categories = "Business"
'.Save
.Display
End With
Set olCi = Nothing
Set olApp = Nothing
End Sub
And, Here is my code (most of it) that retrieves the Outlook contact data.
Private Sub UserForm_Initialize()
Dim objOL As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim objFolder As MAPIFolder
Dim c As Outlook.ContactItem
Dim oc As Integer
Dim i As Integer
Dim lastrow As Integer
Dim PctDone As Variant
Set objOL = New Outlook.Application
Set objNS = objOL.GetNameSpace("MAPI")
Set objFolder = objNS.GetDefaultFolder(olFolderContacts)
Application.Worksheets("Sheet4").Range("A1:K65536").ClearContents
Application.ScreenUpdating = False
Worksheets("Sheet4").Range("B1").Value = "First Name"
Worksheets("Sheet4").Range("C1").Value = "Last Name"
Worksheets("Sheet4").Range("D1").Value = "Company Name"
Worksheets("Sheet4").Range("E1").Value = "Work Phone"
Worksheets("Sheet4").Range("F1").Value = "Email Address"
oc = objFolder.Items.Count
On Error Resume Next
i = 2
For Each c In objFolder.Items
Worksheets("Sheet4").Range("A" & i) = c.COMPANYNAME
Worksheets("Sheet4").Range("B" & i) = c.FirstName
Worksheets("Sheet4").Range("C" & i) = c.LastName
Worksheets("Sheet4").Range("D" & i) = c.COMPANYNAME
Worksheets("Sheet4").Range("E" & i) = c.BusinessTelephoneNumber
Worksheets("Sheet4").Range("F" & i) = c.Email1Address
Worksheets("Sheet4").Range("G" & i) = c.BusinessAddressStreet
Worksheets("Sheet4").Range("H" & i) = c.BusinessAddressCity
Worksheets("Sheet4").Range("I" & i) = c.BusinessAddressState
Worksheets("Sheet4").Range("J" & i) = c.BusinessAddressPostalCode
Worksheets("Sheet4").Range("K" & i) = c.BusinessFaxNumber
i = i + 1
PctDone = i / oc
Call UserForm2.UpdateProgress(PctDone)
Next
Err = 0
lastrow = Worksheets("Sheet4").Range("A65536").End(xlUp).Row
If Worksheets("Sheet4").Range("B65536").End(xlUp).Row > lastrow Then
lastrow = Worksheets("Sheet4").Range("B65536").End(xlUp).Row
End If
i = 1
For i = 1 To lastrow
If Worksheets("Sheet4").Range("B" & i) = "" Then
Worksheets("Sheet4").Range("B" & i) = Worksheets("Sheet4").Range("A" & i)
End If
Next i
Worksheets("Sheet4").Columns("A:K").WrapText = False
Worksheets("Sheet4").Columns("A:K").Select
ActiveWorkbook.Worksheets("Sheet4").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet4").Sort.SortFields.Add Key:=Range("B2:B" & lastrow) _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sheet4").Sort
.SetRange Range("A1:K" & lastrow)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
ListBox1.RowSource = "Sheet4!B2:F" & lastrow
Set objOL = Nothing
Application.ScreenUpdating = True
End Sub
edit Lucas: vba tags added to code.
Sub MakeContact()
'Makes a new Outlook contact from the Prospect Data on "Main" sheet
Dim olApp As Outlook.Application
Dim olCi As Outlook.ContactItem
Dim PText As String
Dim PropText As String
Dim NotesText As String
Set olApp = New Outlook.Application
Set olCi = olApp.CreateItem(olContactItem)
NotesText = VBA.Date & " Proposal History Information" & vbNewLine & vbNewLine
PText = ""
PropText = MsgBox("Do you want to include the current proposal text in your Outlook notes section?" _
& vbNewLine & "This action will retrieve the body text of the currently prpared proposal." _
& vbNewLine & "Click Cancel if you need to prepare the proposal.", vbYesNoCancel + vbQuestion, "Include Proposal Text?")
If PropText = vbYes Then
PText = Sheet15.Range("A17").Value
NotesText = NotesText & "Proposal Text" & vbNewLine & PText & vbNewLine & vbNewLine
End If
If PropText = vbCancel Then
Exit Sub
End If
With olCi
.FirstName = Sheets("Main").tbFIRSTNAME.Value
.Body = "Contact Added " & VBA.Date & vbNewLine & vbNewLine & NotesText & vbNewLine & vbNewLine
'CODE GOES HERE TO COPY AND PASTE A RANGE OF CELLS FROM WORKSHEET TO CONTACT NOTES SECTION?
'APPEND TO EXISTING NOTES
.COMPANYNAME = Sheets("Main").tbCOMPANYNAME.Value
.LastName = Sheets("Main").tbLASTNAME.Value
.BusinessTelephoneNumber = Sheets("Main").tbPHONE.Value
.BusinessFaxNumber = Sheets("Main").tbFAX.Value
.Email1Address = Sheets("Main").tbCONTACTEMAIL.Value
.BusinessAddressCity = Sheets("Main").tbCITY.Value
.BusinessAddressStreet = Sheets("Main").tbADDRESS.Value
.BusinessAddressState = Sheets("Main").tbSTATE.Value
.BusinessAddressPostalCode = Sheets("Main").tbZIP.Value
.SelectedMailingAddress = olBusiness
.Categories = "Business"
'.Save
.Display
End With
Set olCi = Nothing
Set olApp = Nothing
End Sub
And, Here is my code (most of it) that retrieves the Outlook contact data.
Private Sub UserForm_Initialize()
Dim objOL As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim objFolder As MAPIFolder
Dim c As Outlook.ContactItem
Dim oc As Integer
Dim i As Integer
Dim lastrow As Integer
Dim PctDone As Variant
Set objOL = New Outlook.Application
Set objNS = objOL.GetNameSpace("MAPI")
Set objFolder = objNS.GetDefaultFolder(olFolderContacts)
Application.Worksheets("Sheet4").Range("A1:K65536").ClearContents
Application.ScreenUpdating = False
Worksheets("Sheet4").Range("B1").Value = "First Name"
Worksheets("Sheet4").Range("C1").Value = "Last Name"
Worksheets("Sheet4").Range("D1").Value = "Company Name"
Worksheets("Sheet4").Range("E1").Value = "Work Phone"
Worksheets("Sheet4").Range("F1").Value = "Email Address"
oc = objFolder.Items.Count
On Error Resume Next
i = 2
For Each c In objFolder.Items
Worksheets("Sheet4").Range("A" & i) = c.COMPANYNAME
Worksheets("Sheet4").Range("B" & i) = c.FirstName
Worksheets("Sheet4").Range("C" & i) = c.LastName
Worksheets("Sheet4").Range("D" & i) = c.COMPANYNAME
Worksheets("Sheet4").Range("E" & i) = c.BusinessTelephoneNumber
Worksheets("Sheet4").Range("F" & i) = c.Email1Address
Worksheets("Sheet4").Range("G" & i) = c.BusinessAddressStreet
Worksheets("Sheet4").Range("H" & i) = c.BusinessAddressCity
Worksheets("Sheet4").Range("I" & i) = c.BusinessAddressState
Worksheets("Sheet4").Range("J" & i) = c.BusinessAddressPostalCode
Worksheets("Sheet4").Range("K" & i) = c.BusinessFaxNumber
i = i + 1
PctDone = i / oc
Call UserForm2.UpdateProgress(PctDone)
Next
Err = 0
lastrow = Worksheets("Sheet4").Range("A65536").End(xlUp).Row
If Worksheets("Sheet4").Range("B65536").End(xlUp).Row > lastrow Then
lastrow = Worksheets("Sheet4").Range("B65536").End(xlUp).Row
End If
i = 1
For i = 1 To lastrow
If Worksheets("Sheet4").Range("B" & i) = "" Then
Worksheets("Sheet4").Range("B" & i) = Worksheets("Sheet4").Range("A" & i)
End If
Next i
Worksheets("Sheet4").Columns("A:K").WrapText = False
Worksheets("Sheet4").Columns("A:K").Select
ActiveWorkbook.Worksheets("Sheet4").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet4").Sort.SortFields.Add Key:=Range("B2:B" & lastrow) _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sheet4").Sort
.SetRange Range("A1:K" & lastrow)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
ListBox1.RowSource = "Sheet4!B2:F" & lastrow
Set objOL = Nothing
Application.ScreenUpdating = True
End Sub
edit Lucas: vba tags added to code.